diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/expander.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/nlists.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 2621 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 3 |
6 files changed, 1485 insertions, 1183 deletions
diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads index 07e3964..d2b67f1 100644 --- a/gcc/ada/expander.ads +++ b/gcc/ada/expander.ads @@ -132,11 +132,11 @@ package Expander is -- exceptions where it makes sense to temporarily change its value are: -- -- (a) when starting/completing the processing of a generic definition - -- or declaration (see routines Start_Generic_Processing and - -- End_Generic_Processing in Sem_Ch12) + -- or declaration (see routines Start_Generic and End_Generic in + -- Sem_Ch12). -- -- (b) when starting/completing the preanalysis of an expression - -- (see the spec of package Sem for more info on preanalysis.) + -- (see the spec of package Sem for more info on preanalysis). -- -- Note that when processing a spec expression (In_Spec_Expression -- is True) or performing semantic analysis of a generic spec or body diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 5aebd60..3aaffbe 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -124,10 +124,9 @@ package Nlists is -- Used when dealing with a list that can contain pragmas to skip past -- any initial pragmas and return the first element that is not a pragma. -- If the list is empty, or if it contains only pragmas, then Empty is - -- returned. It is an error to call First_Non_Pragma with a Node_Id value - -- or No_List (No_List is not considered to be the same as an empty list). - -- This function also skips N_Null nodes which can result from rewriting - -- unrecognized or incorrect pragmas. + -- returned. It is an error to call this with List = No_List. This function + -- also skips N_Null nodes, which can result from rewriting incorrect + -- pragmas. function Last (List : List_Id) return Node_Or_Entity_Id; pragma Inline (Last); @@ -139,8 +138,8 @@ package Nlists is function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id; -- Obtains the last element of a given node list that is not a pragma. -- If the list is empty, or if it contains only pragmas, then Empty is - -- returned. It is an error to call Last_Non_Pragma with a Node_Id or - -- No_List. (No_List is not considered to be the same as an empty list). + -- returned. It is an error to call this with List = No_List. + -- Unlike First_Non_Pragma, this does not skip N_Null nodes. function List_Length (List : List_Id) return Nat; -- Returns number of items in the given list. If called on No_List it @@ -161,8 +160,8 @@ package Nlists is (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; -- This function returns the next node on a node list, skipping past any -- pragmas, or Empty if there is no non-pragma entry left. The argument - -- must be a member of a node list. This function also skips N_Null nodes - -- which can result from rewriting unrecognized or incorrect pragmas. + -- must be a member of a node list. This function also skips N_Null nodes, + -- which can result from rewriting incorrect pragmas. procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id); pragma Inline (Next_Non_Pragma); @@ -190,8 +189,8 @@ package Nlists is -- pragmas. If Node is the first element of the list, or if the only -- elements preceding it are pragmas, then Empty is returned. The -- argument must be a member of a node list. Note: the implementation - -- does maintain back pointers, so this function executes quickly in - -- constant time. + -- maintains back pointers, so this function executes quickly in constant + -- time. Unlike Next_Non_Pragma, this does not skip N_Null nodes. procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id); pragma Inline (Prev_Non_Pragma); diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 6bed7ae..f14a9a1 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -100,14 +100,13 @@ package Sem_Aux is -- entity is declared or Standard_Standard for library-level entities. function First_Discriminant (Typ : Entity_Id) return Entity_Id; - -- Typ is a type with discriminants. The discriminants are the first - -- entities declared in the type, so normally this is equivalent to - -- First_Entity. The exception arises for tagged types, where the tag - -- itself is prepended to the front of the entity chain, so the - -- First_Discriminant function steps past the tag if it is present. - -- The caller is responsible for checking that the type has discriminants. - -- When called on a private type with unknown discriminants, the function - -- always returns Empty. + -- Typ is a type with discriminants or unknown discriminants. The + -- discriminants are the first entities declared in the type, so normally + -- this is equivalent to First_Entity. The exception arises for tagged + -- types, where the tag itself is prepended to the front of the entity + -- chain, so the First_Discriminant function steps past the tag if it is + -- present. When called on a private type with unknown discriminants, the + -- function always returns Empty. -- WARNING: There is a matching C declaration of this subprogram in fe.h diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8ace16a..b93e823 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -190,7 +190,7 @@ package body Sem_Ch12 is -- (This is just part of the semantic analysis of New_Outer). -- Critically, references to Global within Inner must be preserved, while - -- references to Semi_Global should not preserved, because they must now + -- references to Semi_Global should not be preserved, because they must now -- resolve to an entity within New_Outer. To distinguish between these, we -- use a global variable, Current_Instantiated_Parent, which is set when -- performing a generic copy during instantiation (at 2). This variable is @@ -483,7 +483,7 @@ package body Sem_Ch12 is -- and actuals. Each association becomes a renaming declaration for the -- formal entity. F_Copy is the analyzed list of formals in the generic -- copy. It is used to apply legality checks to the actuals. I_Node is the - -- instantiation node itself. + -- instantiation node. procedure Analyze_Subprogram_Instantiation (N : Node_Id; @@ -519,6 +519,18 @@ package body Sem_Ch12 is -- The body of the wrapper is a call to the actual, with the generated -- pre/postconditon checks added. + procedure Build_Subprogram_Wrappers + (Match, Analyzed_Formal : Node_Id; Renamings : List_Id); + -- Ada 2022: 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. + -- The wrapper declaration and body are appended to Renamings. + -- ???But renaming declarations CAN have aspects specs, + -- and that was true from the start (see AI05-0183-1). + procedure Check_Abbreviated_Instance (N : Node_Id; Parent_Installed : in out Boolean); @@ -558,7 +570,7 @@ package body Sem_Ch12 is -- package cannot be inlined by the front end because front-end inlining -- requires a strict linear order of elaboration. - function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; + function Check_Hidden_Primitives (Renamings : List_Id) return Elist_Id; -- Check if some association between formals and actuals requires to make -- visible primitives of a tagged type, and make those primitives visible. -- Return the list of primitives whose visibility is modified (to restore @@ -723,6 +735,17 @@ package body Sem_Ch12 is -- Determine whether a formal subprogram has a Pre- or Postcondition, -- in which case a subprogram wrapper has to be built for the actual. + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; + -- Determine whether the parameter types and the return type of Subp + -- are fully defined at the point of instantiation. + + function Has_Null_Default (N : Node_Id) return Boolean is + (Nkind (N) in N_Formal_Subprogram_Declaration + and then Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N))); + -- True if N is the declaration of a formal procedure with "is null" + -- as the default. + 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 @@ -786,9 +809,9 @@ package body Sem_Ch12 is -- generic parent of a generic child unit when compiling its body, so -- that full views of types in the parent are made visible. - -- The functions Instantiate_XXX perform various legality checks and build + -- The functions Instantiate_... perform various legality checks and build -- the declarations for instantiated generic parameters. In all of these - -- Formal is the entity in the generic unit, Actual is the entity of + -- Formal is the entity in the generic unit, Actual is the entity or -- expression in the generic associations, and Analyzed_Formal is the -- formal in the generic copy, which contains the semantic information to -- be used to validate the actual. @@ -803,6 +826,11 @@ package body Sem_Ch12 is Actual : Node_Id; Analyzed_Formal : Node_Id; Actual_Decls : List_Id) return List_Id; + -- Actual_Decls is the list of renamings being built; this is used for + -- formal derived types, to determine whether the parent type is another + -- formal derived type in the same generic unit. + -- Note that the call site appends the result of this function onto + -- the same list. function Instantiate_Formal_Subprogram (Formal : Node_Id; @@ -894,6 +922,10 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; + -- Determine whether Subp renames one of the subprograms defined in the + -- generated package Standard. + function Requires_Conformance_Checking (N : Node_Id) return Boolean; -- Determine whether the formal package declaration N requires conformance -- checking with actuals in instantiations. @@ -1087,507 +1119,879 @@ package body Sem_Ch12 is Table_Increment => 200, Table_Name => "Generic_Flags"); - --------------------------- - -- Abandon_Instantiation -- - --------------------------- - - procedure Abandon_Instantiation (N : Node_Id) is - begin - Error_Msg_N ("\instantiation abandoned!", N); - raise Instantiation_Error; - end Abandon_Instantiation; + ------------------ + -- Associations -- + ------------------ + + package Associations is + + type Actual_Kind is + (None, + None_Use_Clause, + -- Used when the "formal" is a use clause; there is no corresponding + -- actual. + Box_Subp_Default, + -- Used for "is <>" as a subprogram default + Box_Actual, + -- Used for explicit "name => <>" and "others => <>" in formal + -- packages. + Name_Exp, + -- Name or expression or .... + -- Used for an explicit_generic_actual_parameter, and also for the + -- default_expression of an in-mode formal, the default_subtype_mark + -- of a formal type, and the default_name of a formal subprogram. + Null_Default, + -- Used for "is null" as a subprogram default. + Exp_Func_Default, + -- Used for "is (expression)" as a subprogram default, + -- which is a language extension (and is different from "is name" + -- without parentheses). + Dummy_Assoc + -- Used for the dummy associations that are created in + -- Save_Global_Defaults. These have Explicit_Generic_Actual_Parameter + -- = Empty and Box_Present = False + ); + -- ???We wouldn't need this enumeration type if we created new node + -- kinds for N_Box_Subp_Default, N_Box_Actual, N_Null_Default, and + -- N_Exp_Func_Default. + + type Generic_Actual_Rec (Kind : Actual_Kind := None) is record + -- Representation of one generic actual parameter + case Kind is + when None | None_Use_Clause | Box_Subp_Default | Box_Actual | + Null_Default | Dummy_Assoc => + null; + when Name_Exp | Exp_Func_Default => + Name_Exp : Node_Id; + end case; + end record; + + type Actual_Origin_Enum is + (None, From_Explicit_Actual, From_Default, From_Others_Box); + -- Indication of where the Actual came from -- explicitly in the + -- instantiation, or defaulted. + + type Assoc_Index is new Pos; + subtype Assoc_Count is Assoc_Index'Base range 0 .. Assoc_Index'Last; + + type Assoc_Rec is record + -- Association between a single formal/actual pair. But we store both + -- the unanalyzed and analyzed formal. + + Un_Formal, An_Formal : Node_Id; -- unanalyzed and analyzed formals + -- An_Formal is the node in the generic copy that corresponds to + -- Un_Formal. The semantic information on this node is used to + -- perform legality checks on the actuals. Because semantic analysis + -- can introduce some anonymous entities or modify the declaration + -- node itself, the correspondence between the two lists is not + -- one-one. In addition to anonymous types, a formal "=" will + -- introduce an implicit equal and opposite "/=". + + Explicit_Assoc : Opt_N_Generic_Association_Id; + -- Explicit association, if any, from the source or generated. + + Actual : Generic_Actual_Rec; + -- Generic actual parameter corresponding to Un_Formal/An_Formal, + -- possibly from defaults or others/boxes. + + Actual_Origin : Actual_Origin_Enum; + -- Reason why Actual was set; where it came from + end record; + + type Assoc_Array is array (Assoc_Index range <>) of Assoc_Rec; + -- One element for each formal and (if legal) for each corresponding + -- actual. + + type Gen_Assocs_Rec (Num_Assocs : Assoc_Count) is record + -- Representation of formal/actual matching. Num_Assocs + -- is the number of formals and (if legal) the number + -- of actuals. + Others_Present : Boolean; + -- True if "others => <>" (only for formal packages) + Assocs : Assoc_Array (1 .. Num_Assocs); + end record; + + function Match_Assocs + (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id) + return Gen_Assocs_Rec; + -- I_Node is the instantiation node. Formals is the list of unanalyzed + -- formals. F_Copy is the analyzed list of formals in the generic copy. + -- Return a Gen_Assocs_Rec with formals, explicit actuals, and default + -- actuals filled in. Check legality rules related to formal/actual + -- matching. + + end Associations; + + procedure Analyze_One_Association + (I_Node : Node_Id; -- instantiation node + Assoc : Associations.Assoc_Rec; + -- Logical 'in out' parameters: + Result_Renamings : List_Id; + Default_Actuals : List_Id; + Actuals_To_Freeze : Elist_Id); + -- Called by Analyze_Associations for each association. The renamings + -- are appended onto Result_Renamings. Defaulted actuals are appended + -- onto Default_Actuals, and actuals that require freezing are + -- appended onto Actuals_To_Freeze. + + procedure Check_Fixed_Point_Warning + (Gen_Assocs : Associations.Gen_Assocs_Rec; + Renamings : List_Id); + -- Warn if any actual is a fixed-point type that has user-defined + -- arithmetic operators, but there is no corresponding formal in the + -- generic, in which case the predefined operators will be used. This + -- merits a warning because of the special semantics of fixed point + -- operators. However, do not warn if the formal is private, because there + -- can be no arithmetic operators in the generic so there no danger of + -- confusion. + + ------------------ + -- Associations -- + ------------------ + + package body Associations is + + generic + with procedure Action (F : Node_Id; Index : Assoc_Index); + procedure Formal_Iter (Formals : List_Id); + -- Iterate through the unanalyzed formals, calling Action for each one. + -- Skip pragmas, but do not skip use clauses. + + function Num_Formals (Formals : List_Id) return Assoc_Count; + -- Note: does not include pragmas that occur in the Formals list; + -- it does include use clauses. + + generic + with procedure Action (F : Node_Id; Index : Assoc_Index); + procedure An_Formal_Iter (An_Formals : List_Id); + -- Iterate through the analyzed formals, calling Action for each one + -- that corresponds to an unanalyzed formal. This should call Action + -- exactly the same number of times that Formal_Iter calls its Action. + -- Skip pragmas, but do not skip use clauses. Skip extraneous + -- analyzed formals in cases where there are multiple ones + -- corresponding to a particular unanalyzed one. + + function Num_An_Formals (F_Copy : List_Id) return Assoc_Count; + -- Number of analyzed formals that correspond directly to unanalyzed + -- formals. There are all sorts of other things in F_Copy, which + -- are not counted. + + procedure Check_Box (I_Node, Actual : Node_Id); + -- Check for errors in "others => <>" and "Name => <>" + + function Default (Un_Formal : Node_Id) return Generic_Actual_Rec; + -- Return the default for a given formal, which can be a name, + -- expression, box, etc. + + procedure Match_Positional + (Src_Assoc : in out Node_Id; Assoc : in out Assoc_Rec); + -- Called by Match_Assocs to match one positional parameter association. + -- If the current formal (in Assoc) is not a use clause, then there is a + -- match, and we set Assoc.Actual and move Src_Assoc to the next one. + + procedure Match_Named + (Src_Assoc : Node_Id; Assoc : in out Assoc_Rec; + Found : in out Boolean); + -- Called by Match_Assocs to match one named parameter association. + -- If the current formal (in Assoc) is not a use clause, and the + -- selector name matches the formal name, then there is a match, + -- and we set Assoc.Actual. We also set the Selector_Name to denote + -- the matched formal, and set Found to True. + + ----------------- + -- Formal_Iter -- + ----------------- + + -- Formal_Iter is straightforward; An_Formal_Iter is not. + + procedure Formal_Iter (Formals : List_Id) is + F : Node_Id := First (Formals); + Index : Assoc_Index := 1; + begin + while Present (F) loop + case Nkind (F) is + when N_Formal_Object_Declaration + | N_Formal_Type_Declaration + | N_Formal_Subprogram_Declaration + | N_Formal_Package_Declaration + | N_Use_Package_Clause + | N_Use_Type_Clause + => + Action (F, Index); + Index := Index + 1; + when N_Pragma => + null; + when others => + raise Program_Error; + end case; - ---------------------------------- - -- Adjust_Inherited_Pragma_Sloc -- - ---------------------------------- + Next (F); + end loop; + end Formal_Iter; - procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is - begin - Adjust_Instantiation_Sloc (N, S_Adjustment); - end Adjust_Inherited_Pragma_Sloc; + ----------------- + -- Num_Formals -- + ----------------- - -------------------------- - -- Analyze_Associations -- - -------------------------- + function Num_Formals (Formals : List_Id) return Assoc_Count is + Result : Assoc_Count := 0; + procedure Action (Ignore_F : Node_Id; Ignore : Assoc_Index); + procedure Action (Ignore_F : Node_Id; Ignore : Assoc_Index) is + begin + Result := Result + 1; + end Action; + procedure Iter is new Formal_Iter (Action); + begin + Iter (Formals); + return Result; + end Num_Formals; - function Analyze_Associations - (I_Node : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id - is - Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; - Assoc_List : constant List_Id := New_List; - Default_Actuals : constant List_Id := New_List; - Gen_Unit : constant Entity_Id := - Defining_Entity (Parent (F_Copy)); + -------------------- + -- An_Formal_Iter -- + -------------------- - Actuals : List_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id; - First_Named : Node_Id := Empty; - Formal : Node_Id; - Match : Node_Id := Empty; - Named : Node_Id; - Saved_Formal : Node_Id; - - Default_Formals : constant List_Id := New_List; - -- If an N_Others_Choice is present, some of the formals may be - -- defaulted. To simplify the treatment of visibility in an instance, - -- we introduce individual defaults for each such formal. These - -- defaults are appended to the list of associations and replace the - -- N_Others_Choice. - - Found_Assoc : Node_Id; - -- Association for the current formal being match. Empty if there are - -- no remaining actuals, or if there is no named association with the - -- name of the formal. - - Is_Named_Assoc : Boolean; - Num_Matched : Nat := 0; - Num_Actuals : Nat := 0; - - Others_Present : Boolean := False; - -- In Ada 2005, indicates partial parameterization of a formal - -- package. As usual an 'others' association must be last in the list. - - procedure Build_Subprogram_Wrappers; - -- Ada 2022: 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, - -- in which case the predefined operations will be used. This merits - -- a warning because of the special semantics of fixed point ops. - - procedure Check_Overloaded_Formal_Subprogram (Formal : Node_Id); - -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance - -- cannot have a named association for it. AI05-0025 extends this rule - -- to formals of formal packages by AI05-0025, and it also applies to - -- box-initialized formals. - - function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; - -- Determine whether the parameter types and the return type of Subp - -- are fully defined at the point of instantiation. - - function Matching_Actual - (F : Entity_Id; - A_F : Entity_Id) return Node_Id; - -- Find actual that corresponds to a given formal parameter. If the - -- 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. - -- - -- In Ada 2005, a named association may be given with a box, in which - -- case Matching_Actual sets Found_Assoc to the generic association, - -- but return Empty for the actual itself. In this case the code below - -- creates a corresponding declaration for the formal. - - function Partial_Parameterization return Boolean; - -- Ada 2005: if no match is found for a given formal, check if the - -- association for it includes a box, or whether the associations - -- include an Others clause. - - procedure Process_Default (Formal : Node_Id); - -- Add a copy of the declaration of a generic formal to the list of - -- associations, and add an explicit box association for its entity - -- if there is none yet, and the default comes from an N_Others_Choice. - - function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; - -- Determine whether Subp renames one of the subprograms defined in the - -- generated package Standard. - - procedure Set_Analyzed_Formal; - -- Find the node in the generic copy that corresponds to a given formal. - -- The semantic information on this node is used to perform legality - -- checks on the actuals. Because semantic analysis can introduce some - -- anonymous entities or modify the declaration node itself, the - -- correspondence between the two lists is not one-one. In addition to - -- anonymous types, the presence a formal equality will introduce an - -- implicit declaration for the corresponding inequality. + procedure An_Formal_Iter (An_Formals : List_Id) is + F : Node_Id := First (An_Formals); + Index : Assoc_Index := 1; + begin + -- The correspondence between unanalyzed and analyzed formals is not + -- one-one; hence this needs to do some fancy footwork to skip some + -- items in the analyzed formals list. In each case where multiple + -- items in An_Formals correspond to a particular unanalyzed formal, + -- we must pick the "main" one. + + while Present (F) loop + case Nkind (F) is + when N_Use_Package_Clause | N_Use_Type_Clause => + Action (F, Index); + Index := Index + 1; + + when N_Formal_Object_Declaration + | N_Formal_Type_Declaration + | N_Formal_Subprogram_Declaration + | N_Package_Declaration + | N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Private_Extension_Declaration + => + if Is_Internal_Name (Chars (Defining_Entity (F))) then + null; + else + Action (F, Index); + Index := Index + 1; + + if Nkind (F) = N_Full_Type_Declaration + and then Nkind (Type_Definition (F)) = + N_Derived_Type_Definition + and then Present (Next (F)) + and then Nkind (Next (F)) = N_Full_Type_Declaration + and then Chars (Defining_Identifier (F)) = + Chars (Defining_Identifier (Next (F))) + then + Next (F); -- Skip full type of derived type + end if; + end if; - ------------------------------- - -- Build_Subprogram_Wrappers -- - ------------------------------- + when N_Subtype_Declaration => + if Nkind (Original_Node (F)) in N_Formal_Type_Declaration + then + pragma Assert + (not Is_Internal_Name (Chars (Defining_Entity (F)))); + Action (F, Index); + Index := Index + 1; + elsif Nkind (Original_Node (F)) in N_Full_Type_Declaration + then + null; + else + -- subtype of a formal object + pragma Assert + (Nkind (Next (F)) = N_Formal_Object_Declaration); + end if; + when N_Pragma => + null; + when N_Formal_Package_Declaration => + -- If there were no errors, this would have been transformed + -- into N_Package_Declaration. + Check_Error_Detected; + pragma Assert (Error_Posted (F)); + Abandon_Instantiation (Instantiation_Node); + when others => + raise Program_Error; + end case; - procedure Build_Subprogram_Wrappers is - function Adjust_Aspect_Sloc (N : Node_Id) return Traverse_Result; - -- Adjust sloc so that errors located at N will be reported with - -- information about the instance and not just about the generic. + Next (F); + end loop; + end An_Formal_Iter; - ------------------------ - -- Adjust_Aspect_Sloc -- - ------------------------ + -------------------- + -- Num_An_Formals -- + -------------------- - function Adjust_Aspect_Sloc (N : Node_Id) return Traverse_Result is + function Num_An_Formals (F_Copy : List_Id) return Assoc_Count is + Result : Assoc_Count := 0; + procedure Action (Ignore_F : Node_Id; Ignore : Assoc_Index); + procedure Action (Ignore_F : Node_Id; Ignore : Assoc_Index) is begin - Adjust_Instantiation_Sloc (N, S_Adjustment); - return OK; - end Adjust_Aspect_Sloc; - - procedure Adjust_Aspect_Slocs is new - Traverse_Proc (Adjust_Aspect_Sloc); - - Formal : constant Entity_Id := - Defining_Unit_Name (Specification (Analyzed_Formal)); - Aspect_Spec : Node_Id; - Decl_Node : Node_Id; - Actual_Name : Node_Id; + Result := Result + 1; + end Action; + procedure Iter is new An_Formal_Iter (Action); + begin + Iter (F_Copy); + return Result; + end Num_An_Formals; - -- Start of processing for Build_Subprogram_Wrappers + --------------- + -- Check_Box -- + --------------- + procedure Check_Box (I_Node, Actual : Node_Id) is 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)); + -- "... => <>" is allowed only in formal packages, not old-fashioned + -- instantiations. - if Is_Overloaded (Match) then - Save_Interps (Match, Actual_Name); + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Comes_From_Source (I_Node) + then + if Actual in N_Others_Choice_Id then + Error_Msg_N + ("OTHERS association not allowed in an instance", Actual); + elsif Box_Present (Actual) then + Error_Msg_N + ("box association not allowed in an instance", Actual); end if; + 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); + -- "others => <>" must come last - begin - Actual_Name := New_Occurrence_Of - (Defining_Entity (Renaming_Decl), Sloc (Match)); - Set_Etype (Actual_Name, Get_Instance_Of (Etype (Formal))); - end; + if Actual in N_Others_Choice_Id + and then Present (Next (Actual)) + then + Error_Msg_N + ("OTHERS must be last association", Actual); end if; + end Check_Box; - Decl_Node := Build_Subprogram_Decl_Wrapper (Formal); + ------------- + -- Default -- + ------------- - -- Transfer aspect specifications from formal subprogram to wrapper + function Default (Un_Formal : Node_Id) return Generic_Actual_Rec is + begin + return Result : Generic_Actual_Rec do + case Nkind (Un_Formal) is + when N_Formal_Object_Declaration => + if Present (Default_Expression (Un_Formal)) then + Result := (Name_Exp, Default_Expression (Un_Formal)); + end if; + when N_Formal_Type_Declaration => + if Present (Default_Subtype_Mark (Un_Formal)) then + Result := (Name_Exp, Default_Subtype_Mark (Un_Formal)); + end if; + when N_Formal_Subprogram_Declaration => + if Present (Default_Name (Un_Formal)) then + pragma Assert (Result.Kind = None); + Result := (Name_Exp, Default_Name (Un_Formal)); + end if; - Set_Aspect_Specifications (Decl_Node, - New_Copy_List_Tree (Aspect_Specifications (Analyzed_Formal))); + if Box_Present (Un_Formal) then + pragma Assert (Result.Kind = None); + Result := (Kind => Box_Subp_Default); + end if; - Aspect_Spec := First (Aspect_Specifications (Decl_Node)); - while Present (Aspect_Spec) loop - Adjust_Aspect_Slocs (Aspect_Spec); - Set_Analyzed (Aspect_Spec, False); - Next (Aspect_Spec); - end loop; + if Present (Expression (Un_Formal)) then + pragma Assert (Result.Kind = None); + Result := (Exp_Func_Default, Expression (Un_Formal)); + end if; - Append_To (Assoc_List, Decl_Node); + if Has_Null_Default (Un_Formal) then + pragma Assert (Result.Kind = None); + Result := (Kind => Null_Default); + end if; - -- 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. + when N_Formal_Package_Declaration => null; + when others => raise Program_Error; + end case; + pragma Assert + (if Result.Kind in Name_Exp | Exp_Func_Default then + Present (Result.Name_Exp)); + end return; + end Default; - Append_To (Assoc_List, - Build_Subprogram_Body_Wrapper (Formal, Actual_Name)); - end Build_Subprogram_Wrappers; + ---------------------- + -- Match_Positional -- + ---------------------- - ---------------------------------------- - -- Check_Overloaded_Formal_Subprogram -- - ---------------------------------------- + procedure Match_Positional + (Src_Assoc : in out Node_Id; Assoc : in out Assoc_Rec) is + begin + if Nkind (Assoc.Un_Formal) not in + N_Use_Package_Clause | N_Use_Type_Clause + then + pragma Assert (No (Assoc.Explicit_Assoc)); + pragma Assert (Assoc.Actual.Kind = None); + Assoc.Explicit_Assoc := Src_Assoc; - procedure Check_Overloaded_Formal_Subprogram (Formal : Node_Id) is - Temp_Formal : Node_Id; + -- A "<>" without "name =>" is illegal syntax - begin - Temp_Formal := First (Formals); - while Present (Temp_Formal) loop - if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration - and then Temp_Formal /= Formal - and then - Chars (Defining_Unit_Name (Specification (Formal))) = - Chars (Defining_Unit_Name (Specification (Temp_Formal))) - then - if Present (Found_Assoc) then + if Box_Present (Src_Assoc) then + Assoc.Actual := (Kind => Box_Actual); + if False then -- ??? + -- Disable this for now, because we have various + -- code that needs to be updated. Error_Msg_N - ("named association not allowed for overloaded formal", - Found_Assoc); - Abandon_Instantiation (Instantiation_Node); + ("box requires named notation", Src_Assoc); end if; + else + Assoc.Actual := + (Name_Exp, + Explicit_Generic_Actual_Parameter (Src_Assoc)); + pragma Assert (Present (Assoc.Actual.Name_Exp)); end if; + Assoc.Actual_Origin := From_Explicit_Actual; - Next (Temp_Formal); - end loop; - end Check_Overloaded_Formal_Subprogram; - - ------------------------------- - -- Check_Fixed_Point_Actual -- - ------------------------------- + Next (Src_Assoc); + end if; + end Match_Positional; - procedure Check_Fixed_Point_Actual (Actual : Node_Id) is - Typ : constant Entity_Id := Entity (Actual); - Prims : constant Elist_Id := Collect_Primitive_Operations (Typ); - Elem : Elmt_Id; - Formal : Node_Id; - Op : Entity_Id; + ----------------- + -- Match_Named -- + ----------------- + procedure Match_Named + (Src_Assoc : Node_Id; Assoc : in out Assoc_Rec; + Found : in out Boolean) is begin - -- Locate primitive operations of the type that are arithmetic - -- operations. + if Nkind (Assoc.Un_Formal) not in + N_Use_Package_Clause | N_Use_Type_Clause + and then Chars (Selector_Name (Src_Assoc)) = + Chars (Defining_Entity (Assoc.Un_Formal)) + then + if Found then -- second formal with the same name + pragma Assert (Comes_From_Source (Src_Assoc)); + Error_Msg_N + ("named association not allowed for " & + "overloaded formal", Src_Assoc); + Abandon_Instantiation (Instantiation_Node); + end if; - Elem := First_Elmt (Prims); - while Present (Elem) loop - if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then + if Assoc.Actual.Kind /= None then + if Comes_From_Source (Src_Assoc) then + Error_Msg_NE + ("duplicate actual for &", + Src_Assoc, Selector_Name (Src_Assoc)); + end if; + else + Assoc.Explicit_Assoc := Src_Assoc; + if Box_Present (Src_Assoc) then + Assoc.Actual := (Kind => Box_Actual); - -- Check whether the generic unit has a formal subprogram of - -- the same name. This does not check types but is good enough - -- to justify a warning. + else + if No (Explicit_Generic_Actual_Parameter (Src_Assoc)) then + Assoc.Actual := (Kind => Dummy_Assoc); + else + Assoc.Actual := + (Name_Exp, + Explicit_Generic_Actual_Parameter (Src_Assoc)); + end if; - Formal := First_Non_Pragma (Formals); - Op := Alias (Node (Elem)); + -- Set Entity (etc.) of the selector name: - while Present (Formal) loop - if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration - and then Chars (Defining_Entity (Formal)) = - Chars (Node (Elem)) - then - exit; - - elsif Nkind (Formal) = N_Formal_Package_Declaration then - declare - Assoc : Node_Id; - Ent : Entity_Id; + declare + A_F : constant Entity_Id := + Defining_Entity (Assoc.An_Formal); + Orig_F : constant Node_Id := + Original_Node (Assoc.An_Formal); + Sel : constant Node_Id := + Selector_Name (Assoc.Explicit_Assoc); + begin + Set_Entity (Sel, A_F); + Set_Etype (Sel, Etype (A_F)); - begin - -- Locate corresponding actual, and check whether it - -- includes a fixed-point type. + if Nkind (Orig_F) = N_Formal_Package_Declaration then + Generate_Reference (Defining_Identifier (Orig_F), Sel); + -- ???Original_Node makes no sense, but we're + -- preserving the old behavior. + else + Generate_Reference (A_F, Sel); + end if; + end; + end if; - Assoc := First (Assoc_List); - while Present (Assoc) loop - exit when - Nkind (Assoc) = N_Package_Renaming_Declaration - and then Chars (Defining_Unit_Name (Assoc)) = - Chars (Defining_Identifier (Formal)); + Assoc.Actual_Origin := From_Explicit_Actual; + Found := True; + end if; + end if; + end Match_Named; - Next (Assoc); - end loop; + ------------------ + -- Match_Assocs -- + ------------------ - if Present (Assoc) then + function Match_Assocs + (I_Node : Node_Id; Formals : List_Id; F_Copy : List_Id) + return Gen_Assocs_Rec + is + Src_Assocs : constant List_Id := Generic_Associations (I_Node); + Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy)); + begin + pragma Assert + (Num_An_Formals (F_Copy) = Num_Formals (Formals) + or else Serious_Errors_Detected > 0); - -- If formal package declares a fixed-point type, - -- and the user-defined operator is derived from - -- a generic instance package, the fixed-point type - -- does not use the corresponding predefined op. + return Result : Gen_Assocs_Rec (Num_Assocs => Num_Formals (Formals)) + do + Result.Others_Present := False; - Ent := First_Entity (Entity (Name (Assoc))); - while Present (Ent) loop - if Is_Fixed_Point_Type (Ent) - and then Present (Op) - and then Is_Generic_Instance (Scope (Op)) - then - return; - end if; + -- Loop through the unanalyzed formals: - Next_Entity (Ent); - end loop; - end if; - end; + declare + procedure Set_Formal (F : Node_Id; Index : Assoc_Index); + procedure Set_Formal (F : Node_Id; Index : Assoc_Index) is + Assoc : Assoc_Rec renames Result.Assocs (Index); + begin + if Nkind (F) in N_Use_Package_Clause | N_Use_Type_Clause then + Assoc := + (Un_Formal => F, + An_Formal => Empty, + Explicit_Assoc => Empty, + Actual => (Kind => None_Use_Clause), + Actual_Origin => None); + else + Assoc := + (Un_Formal => F, + An_Formal => Empty, + Explicit_Assoc => Empty, + Actual => <>, + Actual_Origin => None); end if; + end Set_Formal; + procedure Iter is new Formal_Iter (Set_Formal); + begin + Iter (Formals); + end; - Next (Formal); - end loop; + -- Loop through the analyzed copy of the formals: - if No (Formal) then - Error_Msg_Sloc := Sloc (Node (Elem)); - Error_Msg_NE - ("?instance uses predefined, not primitive, operator&#", - Actual, Node (Elem)); - end if; - end if; - - Next_Elmt (Elem); - end loop; - end Check_Fixed_Point_Actual; + declare + procedure Set_An_Formal (F : Node_Id; Index : Assoc_Index); + procedure Set_An_Formal (F : Node_Id; Index : Assoc_Index) is + Assoc : Assoc_Rec renames Result.Assocs (Index); + begin + Assoc.An_Formal := F; + if Nkind (F) in N_Use_Package_Clause | N_Use_Type_Clause then + pragma Assert + (Nkind (Assoc.Un_Formal) = Nkind (Assoc.An_Formal)); - ------------------------------- - -- Has_Fully_Defined_Profile -- - ------------------------------- + else + case Nkind (Assoc.Un_Formal) is + when N_Formal_Object_Declaration + | N_Formal_Subprogram_Declaration + => + pragma Assert + (Nkind (Assoc.Un_Formal) = + Nkind (Assoc.An_Formal)); + + when N_Formal_Type_Declaration => + pragma Assert + (Nkind (Original_Node (Assoc.An_Formal)) = + N_Formal_Type_Declaration); + pragma Assert + (Nkind (Assoc.An_Formal) in + N_Formal_Type_Declaration + | N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Private_Extension_Declaration + | N_Subtype_Declaration); + + when N_Formal_Package_Declaration => + pragma Assert + (Nkind (Original_Node (Assoc.An_Formal)) = + N_Formal_Package_Declaration); + pragma Assert + (Nkind (Assoc.An_Formal) = N_Package_Declaration); + + when others => pragma Assert (False); + end case; + + pragma Assert + (Chars (Defining_Entity (Assoc.Un_Formal)) = + Chars (Defining_Entity (Assoc.An_Formal))); + end if; + end Set_An_Formal; - function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is - function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; - -- Determine whethet type Typ is fully defined + procedure Iter is new An_Formal_Iter (Set_An_Formal); + begin + pragma Assert + (Num_An_Formals (F_Copy) = Result.Assocs'Last + or else Serious_Errors_Detected > 0); + Iter (F_Copy); + end; - --------------------------- - -- Is_Fully_Defined_Type -- - --------------------------- + -- Loop through actual source associations: - function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is - begin - -- A private type without a full view is not fully defined + declare + Src_Assoc : Node_Id := First (Src_Assocs); + -- Generic association from the source + + function Positional return Boolean is + (Present (Src_Assoc) + and then Src_Assoc not in N_Others_Choice_Id + and then No (Selector_Name (Src_Assoc))); + -- True if Src_Assoc is position; i.e. not named and not others + begin + -- Loop through positional actuals: - if Is_Private_Type (Typ) - and then No (Full_View (Typ)) - then - return False; + for Index in Result.Assocs'Range loop + exit when not Positional; + Match_Positional (Src_Assoc, Result.Assocs (Index)); + end loop; - -- An incomplete type is never fully defined + if Positional then + Error_Msg_Sloc := Sloc (Gen_Unit); + Error_Msg_NE + ("unmatched actual in instantiation of & declared#", + Src_Assoc, Gen_Unit); + else + -- Loop through named actuals and "others => <>": - elsif Is_Incomplete_Type (Typ) then - return False; + while Present (Src_Assoc) loop + Check_Box (I_Node, Src_Assoc); + if Src_Assoc in N_Others_Choice_Id then + Result.Others_Present := True; + exit; + end if; - -- All other types are fully defined + if Positional then + Error_Msg_N + ("invalid positional actual after named one", + Src_Assoc); + else + -- For actual "X => ...", find formal whose name is X. + -- Complain if X has already been specified (could be + -- by a positional association, or by a previous named + -- one). Also complain if there's more than one X. + -- See RM-12.3(9/3) and 12.7(4.1/3). + -- However, this rule does not apply to generated + -- code,because for nested instances, we routinely + -- generate things like: + -- X => ..., X => ... + -- where the first one refers to the first formal X, + -- and the second one refers to the second formal X, + -- and so on. (The X's are formal subprograms in this + -- case.) + + declare + Found : Boolean := False; + begin + for Index in Result.Assocs'Range loop + Match_Named + (Src_Assoc, Result.Assocs (Index), Found); + exit when Found + and then not Comes_From_Source (Src_Assoc); + end loop; - else - return True; - end if; - end Is_Fully_Defined_Type; + if not Found and then Comes_From_Source (Src_Assoc) + then + Error_Msg_Sloc := Sloc (Gen_Unit); + Error_Msg_NE + ("unmatched actual &", + Src_Assoc, Selector_Name (Src_Assoc)); + Error_Msg_NE + ("\in instantiation of & declared#", + Src_Assoc, Gen_Unit); + end if; + end; + end if; - -- Local declarations + Next (Src_Assoc); + end loop; + end if; + end; - Param : Entity_Id; + -- Fill in defaults. For each formal F with no associated actual, + -- if there is "others => <>", set the actual to "F => <>". + -- Otherwise, if the formal has a default, set the actual to + -- "F => default". Otherwise leave it Empty. - -- Start of processing for Has_Fully_Defined_Profile + for Index in Result.Assocs'Range loop + declare + Assoc : Assoc_Rec renames Result.Assocs (Index); + begin + if Assoc.Actual.Kind = None then + pragma Assert (No (Assoc.Explicit_Assoc)); + if Result.Others_Present then + Assoc.Actual := (Kind => Box_Actual); + Assoc.Actual_Origin := From_Others_Box; + else + Assoc.Actual := Default (Assoc.Un_Formal); + if Assoc.Actual.Kind /= None then + Assoc.Actual_Origin := From_Default; + end if; + end if; + end if; + end; + end loop; - begin - -- Check the parameters + -- Check for missing actuals - Param := First_Formal (Subp); - while Present (Param) loop - if not Is_Fully_Defined_Type (Etype (Param)) then - return False; - end if; + for Index in Result.Assocs'Range loop + if Result.Assocs (Index).Actual.Kind = None then + Error_Msg_Sloc := Sloc (Gen_Unit); + Error_Msg_NE + ("missing actual &", + Instantiation_Node, + Defining_Entity (Result.Assocs (Index).Un_Formal)); + Error_Msg_NE + ("\in instantiation of & declared#", + Instantiation_Node, Gen_Unit); + Abandon_Instantiation (Instantiation_Node); + end if; + end loop; + end return; + end Match_Assocs; - Next_Formal (Param); - end loop; + end Associations; - -- Check the return type + --------------------------- + -- Abandon_Instantiation -- + --------------------------- - return Is_Fully_Defined_Type (Etype (Subp)); - end Has_Fully_Defined_Profile; + procedure Abandon_Instantiation (N : Node_Id) is + begin + Error_Msg_N ("\instantiation abandoned!", N); + raise Instantiation_Error; + end Abandon_Instantiation; - --------------------- - -- Matching_Actual -- - --------------------- + ---------------------------------- + -- Adjust_Inherited_Pragma_Sloc -- + ---------------------------------- - function Matching_Actual - (F : Entity_Id; - A_F : Entity_Id) return Node_Id - is - Prev : Node_Id; - Act : Node_Id; + procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is + begin + Adjust_Instantiation_Sloc (N, S_Adjustment); + end Adjust_Inherited_Pragma_Sloc; - begin - Is_Named_Assoc := False; + -------------------------- + -- Analyze_Associations -- + -------------------------- - -- End of list of purely positional parameters + function Analyze_Associations + (I_Node : Node_Id; + Formals : List_Id; + F_Copy : List_Id) return List_Id + is + use Associations; - if No (Actual) or else Nkind (Actual) = N_Others_Choice then - Found_Assoc := Empty; - Act := Empty; + Result_Renamings : constant List_Id := New_List; + -- To be returned. Includes "renamings" broadly interpreted + -- (e.g. subtypes are used for types). - -- Case of positional parameter corresponding to current formal + Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; + Default_Actuals : constant List_Id := New_List; - elsif No (Selector_Name (Actual)) then - -- A "<>" without "name =>" is illegal syntax + Gen_Assocs : constant Gen_Assocs_Rec := + Match_Assocs (I_Node, Formals, F_Copy); - if Box_Present (Actual) then - if False then -- ??? - -- Disable this for now, because we have various code that - -- needs to be updated. - Error_Msg_N ("box requires named notation", Actual); - end if; + begin + for Matching_Actual_Index in Gen_Assocs.Assocs'Range loop + declare + Assoc : Assoc_Rec renames + Gen_Assocs.Assocs (Matching_Actual_Index); + begin + if Nkind (Assoc.Un_Formal) = N_Formal_Package_Declaration + and then Error_Posted (Assoc.An_Formal) + then + -- Restrict this to N_Formal_Package_Declaration, + -- because otherwise many test diffs (and maybe + -- many missing errors). + Abandon_Instantiation (Instantiation_Node); end if; - Found_Assoc := Actual; - Act := Explicit_Generic_Actual_Parameter (Actual); - Num_Matched := Num_Matched + 1; - Next (Actual); + if Nkind (Assoc.Un_Formal) in + N_Use_Package_Clause | N_Use_Type_Clause + then + -- Copy the use clause to where it belongs: + Append (New_Copy_Tree (Assoc.Un_Formal), Result_Renamings); - -- Otherwise scan list of named actuals to find the one with the - -- desired name. All remaining actuals have explicit names. + else + Analyze_One_Association + (I_Node, Assoc, + Result_Renamings, Default_Actuals, Actuals_To_Freeze); + end if; + end; + end loop; - else - Is_Named_Assoc := True; - Found_Assoc := Empty; - Act := Empty; - Prev := Empty; - - while Present (Actual) loop - if Nkind (Actual) = N_Others_Choice then - Found_Assoc := Empty; - Act := Empty; - - elsif Chars (Selector_Name (Actual)) = Chars (F) then - Set_Entity (Selector_Name (Actual), A_F); - Set_Etype (Selector_Name (Actual), Etype (A_F)); - Generate_Reference (A_F, Selector_Name (Actual)); - - Found_Assoc := Actual; - Act := Explicit_Generic_Actual_Parameter (Actual); - Num_Matched := Num_Matched + 1; - exit; - end if; + -- An instantiation freezes all generic actuals, except for incomplete + -- types and subprograms that are not fully defined at the point of + -- instantiation. - Prev := Actual; - Next (Actual); - end loop; + declare + Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); + begin + while Present (Elmt) loop + Freeze_Before (I_Node, Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end; - -- Reset for subsequent searches. In most cases the named - -- associations are in order. If they are not, we reorder them - -- to avoid scanning twice the same actual. This is not just a - -- question of efficiency: there may be multiple defaults with - -- boxes that have the same name. In a nested instantiation we - -- insert actuals for those defaults, and cannot rely on their - -- names to disambiguate them. + -- If there are defaults, normalize the tree by adding explicit + -- associations for them. This is required if the instance appears + -- within a generic. - if Actual = First_Named then - Next (First_Named); + if not Is_Empty_List (Default_Actuals) then + declare + Default : Node_Id; + + begin + Default := First (Default_Actuals); + while Present (Default) loop + Mark_Rewrite_Insertion (Default); + Next (Default); + end loop; - elsif Present (Actual) then - Insert_Before (First_Named, Remove_Next (Prev)); + if No (Generic_Associations (I_Node)) then + Set_Generic_Associations (I_Node, Default_Actuals); + else + Append_List_To (Generic_Associations (I_Node), Default_Actuals); end if; + end; + end if; - Actual := First_Named; - end if; + Check_Fixed_Point_Warning (Gen_Assocs, Result_Renamings); - if Is_Entity_Name (Act) and then Present (Entity (Act)) then - Set_Used_As_Generic_Actual (Entity (Act)); - end if; + return Result_Renamings; + end Analyze_Associations; - return Act; - end Matching_Actual; + ----------------------------- + -- Analyze_One_Association -- + ----------------------------- - ------------------------------ - -- Partial_Parameterization -- - ------------------------------ + procedure Analyze_One_Association + (I_Node : Node_Id; + Assoc : Associations.Assoc_Rec; + -- Logical 'in out' parameters: + Result_Renamings : List_Id; + Default_Actuals : List_Id; + Actuals_To_Freeze : Elist_Id) + is + use Associations; - function Partial_Parameterization return Boolean is - begin - return Others_Present - or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); - end Partial_Parameterization; + procedure Process_Box_Actual (Formal : Node_Id); + -- Called for "Formal => <>", and also if "Formal => ..." is missing, + -- but there is "others => <>". Add a copy of the declaration of the + -- generic formal to the Result_Renamings. --------------------- - -- Process_Default -- + -- Process_Box_Actual -- --------------------- - procedure Process_Default (Formal : Node_Id) is - Loc : constant Source_Ptr := Sloc (I_Node); - F_Id : constant Entity_Id := Defining_Entity (Formal); - Decl : Node_Id; - Default : Node_Id; - Id : Entity_Id; - + procedure Process_Box_Actual (Formal : Node_Id) is + pragma Assert (Assoc.Actual.Kind = Box_Actual); + F_Id : constant Entity_Id := Defining_Entity (Formal); + Decl : constant Node_Id := New_Copy_Tree (Formal); + Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); begin - -- Append copy of formal declaration to associations, and create new - -- defining identifier for it. - - Decl := New_Copy_Tree (Formal); - Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); - if Nkind (Formal) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); @@ -1595,722 +1999,403 @@ package body Sem_Ch12 is Set_Defining_Identifier (Decl, Id); end if; - Append (Decl, Assoc_List); - - if No (Found_Assoc) then -- i.e. 'others' - Default := - Make_Generic_Association (Loc, - Selector_Name => - New_Occurrence_Of (Id, Loc), - Explicit_Generic_Actual_Parameter => Empty); - Set_Box_Present (Default); - Append (Default, Default_Formals); - end if; - end Process_Default; - - --------------------------------- - -- Renames_Standard_Subprogram -- - --------------------------------- - - function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is - Id : Entity_Id; + Append (Decl, Result_Renamings); + end Process_Box_Actual; - begin - Id := Alias (Subp); - while Present (Id) loop - if Scope (Id) = Standard_Standard then - return True; - end if; + Match : Node_Id; - Id := Alias (Id); - end loop; - - return False; - end Renames_Standard_Subprogram; + -- Start of processing for Analyze_One_Association - ------------------------- - -- Set_Analyzed_Formal -- - ------------------------- - - procedure Set_Analyzed_Formal is - Kind : Node_Kind; - - begin - while Present (Analyzed_Formal) loop - Kind := Nkind (Analyzed_Formal); - - case Nkind (Formal) is - when N_Formal_Subprogram_Declaration => - exit when Kind in N_Formal_Subprogram_Declaration - and then - Chars - (Defining_Unit_Name (Specification (Formal))) = - Chars - (Defining_Unit_Name (Specification (Analyzed_Formal))); - - when N_Formal_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 - => - exit; - - when others => - - -- Skip freeze nodes, and nodes inserted to replace - -- unrecognized pragmas. - - exit when - Kind not in N_Formal_Subprogram_Declaration - 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; + begin + if Assoc.Actual_Origin = From_Explicit_Actual + and then Assoc.Actual.Kind = Name_Exp + then + Match := Assoc.Actual.Name_Exp; - Next (Analyzed_Formal); - end loop; - end Set_Analyzed_Formal; + if Is_Entity_Name (Match) and then Present (Entity (Match)) then + Set_Used_As_Generic_Actual (Entity (Match)); + end if; + else + Match := Empty; + end if; - -- Start of processing for Analyze_Associations + case Nkind (Assoc.Un_Formal) is + when N_Formal_Object_Declaration => + if Assoc.Actual.Kind = Box_Actual then + Process_Box_Actual (Assoc.Un_Formal); - begin - Actuals := Generic_Associations (I_Node); - - if Present (Actuals) then + else + Append_List + (Instantiate_Object (Assoc.Un_Formal, Match, Assoc.An_Formal), + Result_Renamings); + + -- GNATprove: For a defaulted in-mode parameter, create + -- an entry in the list of defaulted actuals, for + -- GNATprove use. Do not include these defaults for an + -- instance nested within a generic, because the defaults + -- are also used in the analysis of the enclosing + -- generic, and only defaulted subprograms are relevant + -- there. + + if No (Match) and then not Inside_A_Generic then + Append_To (Default_Actuals, + Make_Generic_Association (Sloc (I_Node), + Selector_Name => + New_Occurrence_Of + (Defining_Identifier + (Assoc.Un_Formal), Sloc (I_Node)), + Explicit_Generic_Actual_Parameter => + New_Copy_Tree (Default_Expression (Assoc.Un_Formal)))); + end if; + end if; - -- Check for an Others choice, indicating a partial parameterization - -- for a formal package. + -- If the object is a call to an expression function, this + -- is a freezing point for it. - Actual := First (Actuals); - while Present (Actual) loop - if Nkind (Actual) = N_Others_Choice then - Others_Present := True; + if Is_Entity_Name (Match) + and then Present (Entity (Match)) + and then Nkind + (Original_Node (Unit_Declaration_Node (Entity (Match)))) + = N_Expression_Function + then + Append_Elmt (Entity (Match), Actuals_To_Freeze); + end if; - if Present (Next (Actual)) then - Error_Msg_N ("OTHERS must be last association", Actual); + when N_Formal_Type_Declaration => + if Assoc.Actual.Kind = Box_Actual then + Process_Box_Actual (Assoc.Un_Formal); + + elsif No (Match) then + if Present (Default_Subtype_Mark (Assoc.Un_Formal)) then + Match := New_Copy (Default_Subtype_Mark (Assoc.Un_Formal)); + Append_List + (Instantiate_Type + (Assoc.Un_Formal, Match, Assoc.An_Formal, + Result_Renamings), + Result_Renamings); + Append_Elmt (Entity (Match), Actuals_To_Freeze); end if; - -- This subprogram is used both for formal packages and for - -- instantiations. For the latter, associations must all be - -- explicit. - - if Nkind (I_Node) /= N_Formal_Package_Declaration - and then Comes_From_Source (I_Node) + else + Analyze (Match); + Append_List + (Instantiate_Type + (Assoc.Un_Formal, Match, Assoc.An_Formal, + Result_Renamings), + Result_Renamings); + + -- An instantiation is a freeze point for the actuals, + -- unless this is a rewritten formal package, or the + -- formal is an Ada 2012 formal incomplete type. + + if Nkind (I_Node) = N_Formal_Package_Declaration + or else + (Ada_Version >= Ada_2012 + and then + Ekind (Defining_Identifier (Assoc.An_Formal)) = + E_Incomplete_Type) then - Error_Msg_N - ("OTHERS association not allowed in an instance", - Actual); + null; + + else + Append_Elmt (Entity (Match), Actuals_To_Freeze); end if; + end if; - -- In any case, nothing to do after the others association + -- A remote access-to-class-wide type is not a legal actual + -- for a generic formal of an access type (E.2.2(17/2)). + -- In GNAT an exception to this rule is introduced when + -- the formal is marked as remote using implementation + -- defined aspect/pragma Remote_Access_Type. In that case + -- the actual must be remote as well. - exit; + -- If the current instantiation is the construction of a + -- local copy for a formal package the actuals may be + -- defaulted, and there is no matching actual to check. - elsif Box_Present (Actual) - and then Comes_From_Source (I_Node) - and then Nkind (I_Node) /= N_Formal_Package_Declaration + if Nkind (Assoc.An_Formal) = N_Formal_Type_Declaration + and then + Nkind (Formal_Type_Definition (Assoc.An_Formal)) = + N_Access_To_Object_Definition + and then Present (Match) then - Error_Msg_N - ("box association not allowed in an instance", Actual); - end if; + declare + Formal_Ent : constant Entity_Id := + Defining_Identifier (Assoc.An_Formal); + begin + if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) + = Is_Remote_Types (Formal_Ent) + then + -- Remoteness of formal and actual match - Next (Actual); - end loop; + null; - -- If named associations are present, save first named association - -- (it may of course be Empty) to facilitate subsequent name search. + elsif Is_Remote_Types (Formal_Ent) then - First_Named := First (Actuals); - while Present (First_Named) - and then Nkind (First_Named) /= N_Others_Choice - and then No (Selector_Name (First_Named)) - loop - Num_Actuals := Num_Actuals + 1; - Next (First_Named); - end loop; - end if; - - Named := First_Named; - while Present (Named) loop - if Nkind (Named) /= N_Others_Choice - and then No (Selector_Name (Named)) - then - Error_Msg_N ("invalid positional actual after named one", Named); - Abandon_Instantiation (Named); - end if; + -- Remote formal, non-remote actual - -- A named association may lack an actual parameter, if it was - -- introduced for a default subprogram that turns out to be local - -- to the outer instantiation. If it has a box association it must - -- correspond to some formal in the generic. + Error_Msg_NE + ("actual for& must be remote", Match, Formal_Ent); - if Nkind (Named) /= N_Others_Choice - and then (Present (Explicit_Generic_Actual_Parameter (Named)) - or else Box_Present (Named)) - then - Num_Actuals := Num_Actuals + 1; - end if; + else + -- Non-remote formal, remote actual - Next (Named); - end loop; + Error_Msg_NE + ("actual for& may not be remote", + Match, Formal_Ent); + end if; + end; + end if; - if Present (Formals) then - Formal := First_Non_Pragma (Formals); - Analyzed_Formal := First_Non_Pragma (F_Copy); + when N_Formal_Subprogram_Declaration => + -- If there is no corresponding actual, this may be case + -- of partial parameterization, or else the formal has a + -- default or a box. - if Present (Actuals) then - Actual := First (Actuals); + if Assoc.Actual.Kind = Box_Actual then + Process_Box_Actual (Assoc.Un_Formal); - -- All formals should have default values + else + Append_To (Result_Renamings, + Instantiate_Formal_Subprogram + (Assoc.Un_Formal, Match, Assoc.An_Formal)); - else - Actual := Empty; - end if; + -- 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. - while Present (Formal) loop - Set_Analyzed_Formal; - Saved_Formal := Next_Non_Pragma (Formal); + if Has_Contracts (Assoc.An_Formal) + and then (Expander_Active or GNATprove_Mode) + then + Build_Subprogram_Wrappers + (Match, Assoc.An_Formal, Result_Renamings); + end if; - case Nkind (Formal) is - when N_Formal_Object_Declaration => - Match := - Matching_Actual - (Defining_Identifier (Formal), - Defining_Identifier (Analyzed_Formal)); + -- An instantiation is a freeze point for the actuals, + -- unless this is a rewritten formal package. - if No (Match) and then Partial_Parameterization then - Process_Default (Formal); + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Nkind (Match) = N_Identifier + and then Is_Subprogram (Entity (Match)) - else - Append_List - (Instantiate_Object (Formal, Match, Analyzed_Formal), - Assoc_List); - - -- For a defaulted in_parameter, create an entry in the - -- 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 - -- defaulted subprograms are relevant there. - - if No (Match) and then not Inside_A_Generic then - Append_To (Default_Actuals, - Make_Generic_Association (Sloc (I_Node), - Selector_Name => - New_Occurrence_Of - (Defining_Identifier (Formal), Sloc (I_Node)), - Explicit_Generic_Actual_Parameter => - New_Copy_Tree (Default_Expression (Formal)))); - end if; - end if; + -- The actual subprogram may rename a routine defined + -- in Standard. Avoid freezing such renamings because + -- subprograms coming from Standard cannot be frozen. - -- If the object is a call to an expression function, this - -- is a freezing point for it. + and then + not Renames_Standard_Subprogram (Entity (Match)) - if Is_Entity_Name (Match) - and then Present (Entity (Match)) - and then Nkind - (Original_Node (Unit_Declaration_Node (Entity (Match)))) - = N_Expression_Function - then - Append_Elmt (Entity (Match), Actuals_To_Freeze); - end if; + -- If the actual subprogram comes from a different + -- unit, it is already frozen, either by a body in + -- that unit or by the end of the declarative part + -- of the unit. This check avoids the freezing of + -- subprograms defined in Standard which are used + -- as generic actuals. - when N_Formal_Type_Declaration => - Match := - Matching_Actual - (Defining_Identifier (Formal), - Defining_Identifier (Analyzed_Formal)); - - if No (Match) then - if Partial_Parameterization then - Process_Default (Formal); - - elsif Present (Default_Subtype_Mark (Formal)) then - Match := New_Copy (Default_Subtype_Mark (Formal)); - Append_List - (Instantiate_Type - (Formal, Match, Analyzed_Formal, Assoc_List), - Assoc_List); - Append_Elmt (Entity (Match), Actuals_To_Freeze); + and then In_Same_Code_Unit (Entity (Match), I_Node) + and then Has_Fully_Defined_Profile (Entity (Match)) + then + -- Mark the subprogram as having a delayed freeze + -- since this may be an out-of-order action. - else - Error_Msg_Sloc := Sloc (Gen_Unit); - Error_Msg_NE - ("missing actual&", - Instantiation_Node, Defining_Identifier (Formal)); - Error_Msg_NE - ("\in instantiation of & declared#", - Instantiation_Node, Gen_Unit); - Abandon_Instantiation (Instantiation_Node); - end if; + Set_Has_Delayed_Freeze (Entity (Match)); + Append_Elmt (Entity (Match), Actuals_To_Freeze); + end if; + end if; - else - Analyze (Match); - Append_List - (Instantiate_Type - (Formal, Match, Analyzed_Formal, Assoc_List), - Assoc_List); - - -- Warn when an actual is a fixed-point with user- - -- defined promitives. The warning is superfluous - -- if the formal is private, because there can be - -- no arithmetic operations in the generic so there - -- no danger of confusion. - - if Is_Fixed_Point_Type (Entity (Match)) - and then not Is_Private_Type - (Defining_Identifier (Analyzed_Formal)) - then - Check_Fixed_Point_Actual (Match); - end if; + -- If this is a nested generic, preserve default for later + -- instantiations. We do this as well for GNATprove use, + -- so that the list of generic associations is complete. - -- An instantiation is a freeze point for the actuals, - -- unless this is a rewritten formal package, or the - -- formal is an Ada 2012 formal incomplete type. + if No (Match) and then Box_Present (Assoc.Un_Formal) then + declare + Subp : constant Entity_Id := + Defining_Unit_Name + (Specification (Last (Result_Renamings))); - if Nkind (I_Node) = N_Formal_Package_Declaration - or else - (Ada_Version >= Ada_2012 - and then - Ekind (Defining_Identifier (Analyzed_Formal)) = - E_Incomplete_Type) - then - null; + begin + Append_To (Default_Actuals, + Make_Generic_Association (Sloc (I_Node), + Selector_Name => + New_Occurrence_Of (Subp, Sloc (I_Node)), + Explicit_Generic_Actual_Parameter => + New_Occurrence_Of (Subp, Sloc (I_Node)))); + end; + end if; - else - Append_Elmt (Entity (Match), Actuals_To_Freeze); - end if; - end if; + when N_Formal_Package_Declaration => + if Assoc.Actual.Kind = Box_Actual then + Process_Box_Actual (Assoc.Un_Formal); - -- A remote access-to-class-wide type is not a legal actual - -- for a generic formal of an access type (E.2.2(17/2)). - -- In GNAT an exception to this rule is introduced when - -- the formal is marked as remote using implementation - -- defined aspect/pragma Remote_Access_Type. In that case - -- the actual must be remote as well. + else + Analyze (Match); + Append_List + (Instantiate_Formal_Package + (Assoc.Un_Formal, Match, Assoc.An_Formal), + Result_Renamings); + + -- Determine whether the actual package needs an explicit + -- freeze node. This is only the case if the actual is + -- declared in the same unit and has a body. Normally + -- packages do not have explicit freeze nodes, and gigi + -- only uses them to elaborate entities in a package + -- body. + + Explicit_Freeze_Check : declare + Actual : constant Entity_Id := Entity (Match); + Gen_Par : Entity_Id; + + Needs_Freezing : Boolean; + P : Node_Id; + + procedure Check_Generic_Parent; + -- The actual may be an instantiation of a unit + -- declared in a previous instantiation. If that + -- one is also in the current compilation, it must + -- itself be frozen before the actual. The actual + -- may be an instantiation of a generic child unit, + -- in which case the same applies to the instance + -- of the parent which must be frozen before the + -- actual. + -- Should this itself be recursive ??? + + -------------------------- + -- Check_Generic_Parent -- + -------------------------- + + procedure Check_Generic_Parent is + Inst : constant Node_Id := + Get_Unit_Instantiation_Node (Actual); + Par : Entity_Id; - -- If the current instantiation is the construction of a - -- local copy for a formal package the actuals may be - -- defaulted, and there is no matching actual to check. + begin + Par := Empty; - if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration - and then - Nkind (Formal_Type_Definition (Analyzed_Formal)) = - N_Access_To_Object_Definition - and then Present (Match) - then - declare - Formal_Ent : constant Entity_Id := - Defining_Identifier (Analyzed_Formal); - begin - if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) - = Is_Remote_Types (Formal_Ent) - then - -- Remoteness of formal and actual match + if Nkind (Parent (Actual)) = N_Package_Specification + then + Par := Scope (Generic_Parent (Parent (Actual))); + if Is_Generic_Instance (Par) then null; - elsif Is_Remote_Types (Formal_Ent) then + -- If the actual is a child generic unit, check + -- whether the instantiation of the parent is + -- also local and must also be frozen now. We + -- must retrieve the instance node to locate the + -- parent instance if any. - -- Remote formal, non-remote actual + elsif Ekind (Par) = E_Generic_Package + and then Is_Child_Unit (Gen_Par) + and then Ekind (Scope (Gen_Par)) = + E_Generic_Package + then + if Nkind (Inst) = N_Package_Instantiation + and then Nkind (Name (Inst)) = + N_Expanded_Name + then + -- Retrieve entity of parent instance - Error_Msg_NE - ("actual for& must be remote", Match, Formal_Ent); + Par := Entity (Prefix (Name (Inst))); + end if; else - -- Non-remote formal, remote actual - - Error_Msg_NE - ("actual for& may not be remote", - Match, Formal_Ent); + Par := Empty; end if; - end; - end if; - - when N_Formal_Subprogram_Declaration => - Match := - Matching_Actual - (Defining_Unit_Name (Specification (Formal)), - Defining_Unit_Name (Specification (Analyzed_Formal))); - - -- If the formal subprogram has the same name as another - -- formal subprogram of the generic, then a named - -- association is illegal (12.3(9)). Exclude named - -- associations that are generated for a nested instance. - - if Present (Match) - and then Is_Named_Assoc - and then Comes_From_Source (Found_Assoc) - then - Check_Overloaded_Formal_Subprogram (Formal); - end if; - - -- If there is no corresponding actual, this may be case - -- of partial parameterization, or else the formal has a - -- default or a box. - - if No (Match) and then Partial_Parameterization then - Process_Default (Formal); - - if Nkind (I_Node) = N_Formal_Package_Declaration then - Check_Overloaded_Formal_Subprogram (Formal); end if; - else - Append_To (Assoc_List, - 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 or GNATprove_Mode) - then - Build_Subprogram_Wrappers; - end if; - - -- An instantiation is a freeze point for the actuals, - -- unless this is a rewritten formal package. - - if Nkind (I_Node) /= N_Formal_Package_Declaration - and then Nkind (Match) = N_Identifier - and then Is_Subprogram (Entity (Match)) - - -- The actual subprogram may rename a routine defined - -- in Standard. Avoid freezing such renamings because - -- subprograms coming from Standard cannot be frozen. - + if Present (Par) + and then Is_Generic_Instance (Par) + and then Scope (Par) = Current_Scope and then - not Renames_Standard_Subprogram (Entity (Match)) - - -- If the actual subprogram comes from a different - -- unit, it is already frozen, either by a body in - -- that unit or by the end of the declarative part - -- of the unit. This check avoids the freezing of - -- subprograms defined in Standard which are used - -- as generic actuals. - - and then In_Same_Code_Unit (Entity (Match), I_Node) - and then Has_Fully_Defined_Profile (Entity (Match)) + (No (Freeze_Node (Par)) + or else + not Is_List_Member (Freeze_Node (Par))) then - -- Mark the subprogram as having a delayed freeze - -- since this may be an out-of-order action. - - Set_Has_Delayed_Freeze (Entity (Match)); - Append_Elmt (Entity (Match), Actuals_To_Freeze); + Set_Has_Delayed_Freeze (Par); + Append_Elmt (Par, Actuals_To_Freeze); end if; - end if; - - -- If this is a nested generic, preserve default for later - -- 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 - declare - Subp : constant Entity_Id := - Defining_Unit_Name - (Specification (Last (Assoc_List))); - - begin - Append_To (Default_Actuals, - Make_Generic_Association (Sloc (I_Node), - Selector_Name => - New_Occurrence_Of (Subp, Sloc (I_Node)), - Explicit_Generic_Actual_Parameter => - New_Occurrence_Of (Subp, Sloc (I_Node)))); - end; - end if; - - when N_Formal_Package_Declaration => - -- The name of the formal package may be hidden by the - -- formal parameter itself. + end Check_Generic_Parent; - if Error_Posted (Analyzed_Formal) then - Abandon_Instantiation (Instantiation_Node); + -- Start of processing for Explicit_Freeze_Check + begin + if Present (Renamed_Entity (Actual)) then + Gen_Par := + Generic_Parent (Specification + (Unit_Declaration_Node + (Renamed_Entity (Actual)))); else - Match := - Matching_Actual - (Defining_Identifier (Formal), - Defining_Identifier - (Original_Node (Analyzed_Formal))); + Gen_Par := + Generic_Parent (Specification + (Unit_Declaration_Node (Actual))); end if; - if No (Match) then - if Partial_Parameterization then - Process_Default (Formal); - - else - Error_Msg_Sloc := Sloc (Gen_Unit); - Error_Msg_NE - ("missing actual&", - Instantiation_Node, Defining_Identifier (Formal)); - Error_Msg_NE - ("\in instantiation of & declared#", - Instantiation_Node, Gen_Unit); - - Abandon_Instantiation (Instantiation_Node); - end if; + if not Expander_Active + or else not Has_Completion (Actual) + or else not In_Same_Source_Unit (I_Node, Actual) + or else Is_Frozen (Actual) + or else + (Present (Renamed_Entity (Actual)) + and then + not In_Same_Source_Unit + (I_Node, (Renamed_Entity (Actual)))) + then + null; else - Analyze (Match); - Append_List - (Instantiate_Formal_Package - (Formal, Match, Analyzed_Formal), - Assoc_List); - - -- Determine whether the actual package needs an explicit - -- freeze node. This is only the case if the actual is - -- declared in the same unit and has a body. Normally - -- packages do not have explicit freeze nodes, and gigi - -- only uses them to elaborate entities in a package - -- body. - - Explicit_Freeze_Check : declare - Actual : constant Entity_Id := Entity (Match); - Gen_Par : Entity_Id; - - Needs_Freezing : Boolean; - P : Node_Id; - - procedure Check_Generic_Parent; - -- The actual may be an instantiation of a unit - -- declared in a previous instantiation. If that - -- one is also in the current compilation, it must - -- itself be frozen before the actual. The actual - -- may be an instantiation of a generic child unit, - -- in which case the same applies to the instance - -- of the parent which must be frozen before the - -- actual. - -- Should this itself be recursive ??? - - -------------------------- - -- Check_Generic_Parent -- - -------------------------- - - procedure Check_Generic_Parent is - Inst : constant Node_Id := - Get_Unit_Instantiation_Node (Actual); - Par : Entity_Id; + -- Finally we want to exclude such freeze nodes + -- from statement sequences, which freeze + -- everything before them. + -- Is this strictly necessary ??? - begin - Par := Empty; + Needs_Freezing := True; - if Nkind (Parent (Actual)) = N_Package_Specification - then - Par := Scope (Generic_Parent (Parent (Actual))); - - if Is_Generic_Instance (Par) then - null; - - -- If the actual is a child generic unit, check - -- whether the instantiation of the parent is - -- also local and must also be frozen now. We - -- must retrieve the instance node to locate the - -- parent instance if any. - - elsif Ekind (Par) = E_Generic_Package - and then Is_Child_Unit (Gen_Par) - and then Ekind (Scope (Gen_Par)) = - E_Generic_Package - then - if Nkind (Inst) = N_Package_Instantiation - and then Nkind (Name (Inst)) = - N_Expanded_Name - then - -- Retrieve entity of parent instance - - Par := Entity (Prefix (Name (Inst))); - end if; - - else - Par := Empty; - end if; - end if; + P := Parent (I_Node); + while Nkind (P) /= N_Compilation_Unit loop + if Nkind (P) = N_Handled_Sequence_Of_Statements + then + Needs_Freezing := False; + exit; + end if; - if Present (Par) - and then Is_Generic_Instance (Par) - and then Scope (Par) = Current_Scope - and then - (No (Freeze_Node (Par)) - or else - not Is_List_Member (Freeze_Node (Par))) - then - Set_Has_Delayed_Freeze (Par); - Append_Elmt (Par, Actuals_To_Freeze); - end if; - end Check_Generic_Parent; + P := Parent (P); + end loop; - -- Start of processing for Explicit_Freeze_Check + if Needs_Freezing then + Check_Generic_Parent; - begin - if Present (Renamed_Entity (Actual)) then - Gen_Par := - Generic_Parent (Specification - (Unit_Declaration_Node - (Renamed_Entity (Actual)))); - else - Gen_Par := - Generic_Parent (Specification - (Unit_Declaration_Node (Actual))); - end if; + -- If the actual is a renaming of a proper + -- instance of the formal package, indicate + -- that it is the instance that must be frozen. - if not Expander_Active - or else not Has_Completion (Actual) - or else not In_Same_Source_Unit (I_Node, Actual) - or else Is_Frozen (Actual) - or else - (Present (Renamed_Entity (Actual)) - and then - not In_Same_Source_Unit - (I_Node, (Renamed_Entity (Actual)))) + if Nkind (Parent (Actual)) = + N_Package_Renaming_Declaration then - null; - + Set_Has_Delayed_Freeze + (Renamed_Entity (Actual)); + Append_Elmt + (Renamed_Entity (Actual), + Actuals_To_Freeze); else - -- Finally we want to exclude such freeze nodes - -- from statement sequences, which freeze - -- everything before them. - -- Is this strictly necessary ??? - - Needs_Freezing := True; - - P := Parent (I_Node); - while Nkind (P) /= N_Compilation_Unit loop - if Nkind (P) = N_Handled_Sequence_Of_Statements - then - Needs_Freezing := False; - exit; - end if; - - P := Parent (P); - end loop; - - if Needs_Freezing then - Check_Generic_Parent; - - -- If the actual is a renaming of a proper - -- instance of the formal package, indicate - -- that it is the instance that must be frozen. - - if Nkind (Parent (Actual)) = - N_Package_Renaming_Declaration - then - Set_Has_Delayed_Freeze - (Renamed_Entity (Actual)); - Append_Elmt - (Renamed_Entity (Actual), - Actuals_To_Freeze); - else - Set_Has_Delayed_Freeze (Actual); - Append_Elmt (Actual, Actuals_To_Freeze); - end if; - end if; + Set_Has_Delayed_Freeze (Actual); + Append_Elmt (Actual, Actuals_To_Freeze); end if; - end Explicit_Freeze_Check; + end if; end if; - - -- Copy use clauses to where they belong - - when N_Use_Package_Clause - | N_Use_Type_Clause - => - Append (New_Copy_Tree (Formal), Assoc_List); - - when others => - raise Program_Error; - end case; - - -- Check here the correct use of Ghost entities in generic - -- instantiations, as now the generic has been resolved and - -- we know which formal generic parameters are ghost (SPARK - -- RM 6.9(10)). - - if Nkind (Formal) not in N_Use_Package_Clause - | N_Use_Type_Clause - then - Check_Ghost_Context_In_Generic_Association - (Actual => Match, - Formal => Defining_Entity (Analyzed_Formal)); - end if; - - Formal := Saved_Formal; - Next_Non_Pragma (Analyzed_Formal); - end loop; - - if Num_Actuals > Num_Matched then - Error_Msg_Sloc := Sloc (Gen_Unit); - - if Present (Selector_Name (Actual)) then - Error_Msg_NE - ("unmatched actual &", Actual, Selector_Name (Actual)); - Error_Msg_NE - ("\in instantiation of & declared#", Actual, Gen_Unit); - else - Error_Msg_NE - ("unmatched actual in instantiation of & declared#", - Actual, Gen_Unit); - end if; - end if; - - elsif Present (Actuals) then - Error_Msg_N - ("too many actuals in generic instantiation", Instantiation_Node); - end if; - - -- An instantiation freezes all generic actuals. The only exceptions - -- to this are incomplete types and subprograms which are not fully - -- defined at the point of instantiation. - - declare - Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); - begin - while Present (Elmt) loop - Freeze_Before (I_Node, Node (Elmt)); - Next_Elmt (Elmt); - end loop; - end; - - -- If there are default subprograms, normalize the tree by adding - -- explicit associations for them. This is required if the instance - -- appears within a generic. - - if not Is_Empty_List (Default_Actuals) then - declare - Default : Node_Id; - - begin - Default := First (Default_Actuals); - while Present (Default) loop - Mark_Rewrite_Insertion (Default); - Next (Default); - end loop; - - if No (Actuals) then - Set_Generic_Associations (I_Node, Default_Actuals); - else - Append_List_To (Actuals, Default_Actuals); + end Explicit_Freeze_Check; end if; - end; - end if; - -- If this is a formal package, normalize the parameter list by adding - -- explicit box associations for the formals that are covered by an - -- N_Others_Choice. + when others => + raise Program_Error; + end case; - Append_List (Default_Formals, Formals); + -- Check for correct use of Ghost entities in generic + -- instantiations (SPARK RM 6.9(10)). - return Assoc_List; - end Analyze_Associations; + Check_Ghost_Context_In_Generic_Association + (Actual => Match, + Formal => Defining_Entity (Assoc.An_Formal)); + end Analyze_One_Association; ------------------------------- -- Analyze_Formal_Array_Type -- @@ -2944,9 +3029,9 @@ package body Sem_Ch12 is -- part, so that names with the proper types are available in the -- specification of the formal package. - -- On the other hand, if there are no associations, then all the - -- formals must have defaults, and this will be checked by the - -- call to Analyze_Associations. + -- On the other hand, if there are no associations (as in "new G;"), + -- then all the formals must have defaults, and this will be checked + -- by the call to Analyze_Associations. if Box_Present (N) or else Nkind (First (Generic_Associations (N))) = N_Others_Choice @@ -3402,9 +3487,7 @@ package body Sem_Ch12 is -- A formal abstract procedure cannot have a null default -- (RM 12.6(4.1/2)). - if Nkind (Spec) = N_Procedure_Specification - and then Null_Present (Spec) - then + if Has_Null_Default (N) then Error_Msg_N ("a formal abstract subprogram cannot default to null", Spec); end if; @@ -4291,7 +4374,7 @@ package body Sem_Ch12 is Inline_Now : Boolean := False; Needs_Body : Boolean; Parent_Installed : Boolean := False; - Renaming_List : List_Id; + Renamings : List_Id; Unit_Renaming : Node_Id; Vis_Prims_List : Elist_Id := No_Elist; @@ -4523,13 +4606,13 @@ package body Sem_Ch12 is Set_Private_Declarations (Act_Spec, New_List); end if; - Renaming_List := + Renamings := Analyze_Associations (I_Node => N, Formals => Generic_Formal_Declarations (Act_Tree), F_Copy => Generic_Formal_Declarations (Gen_Decl)); - Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); + Vis_Prims_List := Check_Hidden_Primitives (Renamings); Set_Instance_Env (Gen_Unit, Act_Decl_Id); Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); @@ -4549,16 +4632,16 @@ package body Sem_Ch12 is Make_Defining_Identifier (Loc, Chars (Gen_Unit)), Name => New_Occurrence_Of (Act_Decl_Id, Loc)); - Append (Unit_Renaming, Renaming_List); + Append (Unit_Renaming, Renamings); -- The renaming declarations are the first local declarations of the -- new unit. if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then Insert_List_Before - (First (Visible_Declarations (Act_Spec)), Renaming_List); + (First (Visible_Declarations (Act_Spec)), Renamings); else - Set_Visible_Declarations (Act_Spec, Renaming_List); + Set_Visible_Declarations (Act_Spec, Renamings); end if; Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); @@ -5428,6 +5511,8 @@ package body Sem_Ch12 is return False; end Is_Inlined_Or_Child_Of_Inlined; + -- Start of processing for Need_Subprogram_Instance_Body + begin -- Must be in the main unit or inlined (or child of inlined) @@ -5494,7 +5579,7 @@ package body Sem_Ch12 is Pack_Id : Entity_Id; Parent_Installed : Boolean := False; - Renaming_List : List_Id; + Renamings : List_Id; -- The list of declarations that link formals and actuals of the -- instance. These are subtype declarations for formal types, and -- renaming declarations for other formals. The subprogram declaration @@ -5552,7 +5637,7 @@ package body Sem_Ch12 is Make_Package_Declaration (Loc, Specification => Make_Package_Specification (Loc, Defining_Unit_Name => Pack_Id, - Visible_Declarations => Renaming_List, + Visible_Declarations => Renamings, End_Label => Empty)); Set_Instance_Spec (N, Pack_Decl); @@ -5693,7 +5778,7 @@ package body Sem_Ch12 is -- itself, do not add this renaming declaration, to prevent -- ambiguities when there is a call with that name in the body. - Renaming_Decl := First (Renaming_List); + Renaming_Decl := First (Renamings); while Present (Renaming_Decl) loop if Nkind (Renaming_Decl) = N_Subprogram_Renaming_Declaration and then @@ -5706,7 +5791,7 @@ package body Sem_Ch12 is end loop; if No (Renaming_Decl) then - Append (Unit_Renaming, Renaming_List); + Append (Unit_Renaming, Renamings); end if; end Build_Subprogram_Renaming; @@ -5850,13 +5935,13 @@ package body Sem_Ch12 is Set_Must_Override (Act_Spec, Must_Override (N)); Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); - Renaming_List := + Renamings := Analyze_Associations (I_Node => N, Formals => Generic_Formal_Declarations (Act_Tree), F_Copy => Generic_Formal_Declarations (Gen_Decl)); - Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); + Vis_Prims_List := Check_Hidden_Primitives (Renamings); -- The subprogram itself cannot contain a nested instance, so the -- current parent is left empty. @@ -5885,14 +5970,14 @@ package body Sem_Ch12 is Hide_Current_Scope; end if; - Append (Act_Decl, Renaming_List); + Append (Act_Decl, Renamings); -- Contract-related source pragmas that follow a generic subprogram -- must be instantiated explicitly because they are not part of the -- subprogram template. Instantiate_Subprogram_Contract - (Original_Node (Gen_Decl), Renaming_List); + (Original_Node (Gen_Decl), Renamings); Build_Subprogram_Renaming; @@ -6304,6 +6389,92 @@ package body Sem_Ch12 is return Body_Node; end Build_Subprogram_Body_Wrapper; + ------------------------------- + -- Build_Subprogram_Wrappers -- + ------------------------------- + + procedure Build_Subprogram_Wrappers + (Match, Analyzed_Formal : Node_Id; Renamings : List_Id) + is + function Adjust_Aspect_Sloc (N : Node_Id) return Traverse_Result; + -- Adjust Sloc so that errors will be reported on the instance rather + -- than the generic. + + ------------------------ + -- Adjust_Aspect_Sloc -- + ------------------------ + + function Adjust_Aspect_Sloc (N : Node_Id) return Traverse_Result is + begin + Adjust_Instantiation_Sloc (N, S_Adjustment); + return OK; + end Adjust_Aspect_Sloc; + + procedure Adjust_Aspect_Slocs is new + Traverse_Proc (Adjust_Aspect_Sloc); + + Formal : constant Entity_Id := + Defining_Unit_Name (Specification (Analyzed_Formal)); + Aspect_Spec : Node_Id; + Decl_Node : Node_Id; + Actual_Name : Node_Id; + + -- Start of processing for Build_Subprogram_Wrappers + + 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 (Renamings); + + 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 + Adjust_Aspect_Slocs (Aspect_Spec); + Set_Analyzed (Aspect_Spec, False); + Next (Aspect_Spec); + end loop; + + Append_To (Renamings, 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 (Renamings, + Build_Subprogram_Body_Wrapper (Formal, Actual_Name)); + end Build_Subprogram_Wrappers; + ------------------------------------------- -- Build_Instance_Compilation_Unit_Nodes -- ------------------------------------------- @@ -6859,6 +7030,122 @@ package body Sem_Ch12 is end loop; end Check_Formal_Package_Instance; + ------------------------------- + -- Check_Fixed_Point_Warning -- + ------------------------------- + + procedure Check_Fixed_Point_Warning + (Gen_Assocs : Associations.Gen_Assocs_Rec; + Renamings : List_Id) + is + use Associations; + begin + for Type_Index in Gen_Assocs.Assocs'Range loop + declare + Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Type_Index); + begin + if Nkind (Assoc.An_Formal) = N_Formal_Type_Declaration + and then Is_Fixed_Point_Type (Defining_Entity (Assoc.An_Formal)) + and then Assoc.Actual.Kind = Name_Exp + then + declare + Typ : constant Entity_Id := Entity (Assoc.Actual.Name_Exp); + pragma Assert (Is_Fixed_Point_Type (Typ)); + + Prims : constant Elist_Id := + Collect_Primitive_Operations (Typ); + Elem : Elmt_Id := First_Elmt (Prims); + Formal : Node_Id; + Op : Entity_Id; + begin + -- Locate primitive operations of the type that are + -- arithmetic operations. + + while Present (Elem) loop + if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then + + -- Check whether the generic unit has a formal + -- subprogram of the same name. This does not check + -- types but is good enough to justify a warning. + + Op := Alias (Node (Elem)); + + for Op_Index in Type_Index + 1 .. + Gen_Assocs.Assocs'Last + loop + Formal := Gen_Assocs.Assocs (Op_Index).Un_Formal; + + if Nkind (Formal) = + N_Formal_Concrete_Subprogram_Declaration + and then Chars (Defining_Entity (Formal)) = + Chars (Node (Elem)) + then + goto OK; + + elsif Nkind (Formal) = N_Formal_Package_Declaration + then + declare + Assoc : Node_Id; + Ent : Entity_Id; + + begin + -- Locate corresponding actual, and check + -- whether it includes a fixed-point type. + + Assoc := First (Renamings); + while Present (Assoc) loop + exit when + Nkind (Assoc) = + N_Package_Renaming_Declaration + and then + Chars (Defining_Unit_Name (Assoc)) = + Chars (Defining_Identifier (Formal)); + + Next (Assoc); + end loop; + + if Present (Assoc) then + -- If the formal package declares a + -- fixed-point type, and the user-defined + -- operator is derived from a generic + -- instance package, the fixed-point type + -- does not use the corresponding + -- predefined op. + + Ent := + First_Entity (Entity (Name (Assoc))); + while Present (Ent) loop + if Is_Fixed_Point_Type (Ent) + and then Present (Op) + and then + Is_Generic_Instance (Scope (Op)) + then + goto OK; + end if; + + Next_Entity (Ent); + end loop; + end if; + end; + end if; + end loop; + + Error_Msg_Sloc := Sloc (Node (Elem)); + Error_Msg_NE + ("?instance uses predefined, not primitive, " & + "operator&#", + Assoc.Actual.Name_Exp, Node (Elem)); + <<OK>> null; + end if; + + Next_Elmt (Elem); + end loop; + end; + end if; + end; + end loop; + end Check_Fixed_Point_Warning; + --------------------------- -- Check_Formal_Packages -- --------------------------- @@ -7034,6 +7321,8 @@ package body Sem_Ch12 is return False; end Scope_Within_Body_Or_Same; + -- Start of processing for Check_Actual_Type + begin -- The exchange is only needed if the generic is defined -- within a package which is not a common ancestor of the @@ -7812,6 +8101,8 @@ package body Sem_Ch12 is end if; end Check_Private_Type; + -- Start of processing for Check_Private_View + begin if Present (Typ) then -- If the type appears in a subtype declaration, the subtype in @@ -7874,20 +8165,20 @@ package body Sem_Ch12 is -- Check_Hidden_Primitives -- ----------------------------- - function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is + function Check_Hidden_Primitives (Renamings : List_Id) return Elist_Id is Actual : Node_Id; Gen_T : Entity_Id; Result : Elist_Id := No_Elist; begin - if No (Assoc_List) then + if No (Renamings) then return No_Elist; end if; -- Traverse the list of associations between formals and actuals -- searching for renamings of tagged types - Actual := First (Assoc_List); + Actual := First (Renamings); while Present (Actual) loop if Nkind (Actual) = N_Subtype_Declaration then Gen_T := Generic_Parent_Type (Actual); @@ -9670,6 +9961,62 @@ package body Sem_Ch12 is return False; end Has_Contracts; + ------------------------------- + -- Has_Fully_Defined_Profile -- + ------------------------------- + + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; + -- Determine whethet type Typ is fully defined + + --------------------------- + -- Is_Fully_Defined_Type -- + --------------------------- + + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is + begin + -- A private type without a full view is not fully defined + + if Is_Private_Type (Typ) + and then No (Full_View (Typ)) + then + return False; + + -- An incomplete type is never fully defined + + elsif Is_Incomplete_Type (Typ) then + return False; + + -- All other types are fully defined + + else + return True; + end if; + end Is_Fully_Defined_Type; + + -- Local declarations + + Param : Entity_Id; + + -- Start of processing for Has_Fully_Defined_Profile + + begin + -- Check the parameters + + Param := First_Formal (Subp); + while Present (Param) loop + if not Is_Fully_Defined_Type (Etype (Param)) then + return False; + end if; + + Next_Formal (Param); + end loop; + + -- Check the return type + + return Is_Fully_Defined_Type (Etype (Subp)); + end Has_Fully_Defined_Profile; + ---------- -- Hash -- ---------- @@ -10458,6 +10805,26 @@ package body Sem_Ch12 is end if; end Install_Hidden_Primitives; + --------------------------------- + -- Renames_Standard_Subprogram -- + --------------------------------- + + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is + Id : Entity_Id; + + begin + Id := Alias (Subp); + while Present (Id) loop + if Scope (Id) = Standard_Standard then + return True; + end if; + + Id := Alias (Id); + end loop; + + return False; + end Renames_Standard_Subprogram; + ------------------------------- -- Restore_Hidden_Primitives -- ------------------------------- @@ -10976,9 +11343,7 @@ package body Sem_Ch12 is if Requires_Conformance_Checking (Formal) then declare I_Pack : constant Entity_Id := Make_Temporary (Loc, 'P'); - I_Nam : Node_Id; - begin Set_Is_Internal (I_Pack); Mutate_Ekind (I_Pack, E_Package); @@ -11222,9 +11587,7 @@ package body Sem_Ch12 is Nam := Make_Identifier (Loc, Chars (Formal_Sub)); end if; - elsif Nkind (Specification (Formal)) = N_Procedure_Specification - and then Null_Present (Specification (Formal)) - then + elsif Has_Null_Default (Formal) then -- Generate null body for procedure, for use in the instance Decl_Node := @@ -11281,13 +11644,7 @@ package body Sem_Ch12 is return Decl_Node; else - Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); - Error_Msg_NE - ("missing actual&", Instantiation_Node, Formal_Sub); - Error_Msg_NE - ("\in instantiation of & declared#", - Instantiation_Node, Scope (Analyzed_S)); - Abandon_Instantiation (Instantiation_Node); + pragma Assert (False); end if; Decl_Node := @@ -11426,14 +11783,6 @@ package body Sem_Ch12 is Acc_Def := Access_Definition (Formal); end if; - -- Sloc for error message on missing actual - - Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); - - if Get_Instance_Of (Gen_Obj) /= Gen_Obj then - Error_Msg_N ("duplicate instantiation of generic parameter", Actual); - end if; - Set_Parent (List, Act_Assoc); -- OUT present @@ -11444,21 +11793,11 @@ package body Sem_Ch12 is -- renaming declaration. The actual is the name being renamed. We -- 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 + -- of Relocate_Node is incorrect if the instance is nested within a -- 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 - ("missing actual &", - Instantiation_Node, Gen_Obj); - Error_Msg_NE - ("\in instantiation of & declared#", - Instantiation_Node, Scope (A_Gen_Obj)); - Abandon_Instantiation (Instantiation_Node); - end if; - if Present (Subt_Mark) then Decl_Node := Make_Object_Renaming_Declaration (Loc, @@ -11622,14 +11961,14 @@ package body Sem_Ch12 is (Actual => Actual, Formal => A_Gen_Obj); - -- Formal in-parameter + -- Formal in-mode parameter else - -- The instantiation of a generic formal in-parameter is constant - -- declaration. The actual is the expression for that declaration. - -- Its type is a full copy of the type of the formal. This may be - -- an access to subprogram, for which we need to generate entities - -- for the formals in the new signature. + -- The instantiation of a generic formal in-mode parameter is a + -- constant declaration. The actual is the expression for that + -- declaration. Its type is a full copy of the type of the + -- formal. This may be an access to subprogram, for which we need + -- to generate entities for the formals in the new signature. if Present (Actual) then if Present (Subt_Mark) then @@ -11750,37 +12089,7 @@ package body Sem_Ch12 is Set_Analyzed (Expression (Decl_Node), False); else - Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj); - Error_Msg_NE ("\in instantiation of & declared#", - Instantiation_Node, Scope (A_Gen_Obj)); - - if Is_Scalar_Type (Etype (A_Gen_Obj)) then - - -- Create dummy constant declaration so that instance can be - -- analyzed, to minimize cascaded visibility errors. - - if Present (Subt_Mark) then - Def := Subt_Mark; - else pragma Assert (Present (Acc_Def)); - Def := Acc_Def; - end if; - - Decl_Node := - Make_Object_Declaration (Loc, - Defining_Identifier => New_Copy (Gen_Obj), - Constant_Present => True, - Null_Exclusion_Present => Null_Exclusion_Present (Formal), - Object_Definition => New_Copy (Def), - Expression => - Make_Attribute_Reference (Sloc (Gen_Obj), - Attribute_Name => Name_First, - Prefix => New_Copy (Def))); - - Append (Decl_Node, List); - - else - Abandon_Instantiation (Instantiation_Node); - end if; + pragma Assert (False); end if; end if; @@ -12880,7 +13189,7 @@ package body Sem_Ch12 is Act_T : Entity_Id; Ancestor : Entity_Id := Empty; Decl_Node : Node_Id; - Decl_Nodes : List_Id; + Decl_Nodes : List_Id; -- result Loc : Source_Ptr; Subt : Entity_Id; @@ -12892,7 +13201,7 @@ package body Sem_Ch12 is -- There are a number of constructs in which a discrete type with -- predicates is illegal, e.g. as an index in an array type declaration. -- If a generic type is used is such a construct in a generic package - -- declaration, it carries the flag No_Predicate_On_Actual. it is part + -- declaration, it carries the flag No_Predicate_On_Actual. It is part -- of the generic contract that the actual cannot have predicates. function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; @@ -13042,9 +13351,8 @@ package body Sem_Ch12 is -- wide types), or designated types (when dealing with anonymous -- access types) of Gen_T and Act_T are statically matching subtypes. - return ((Base_Type (T) = Act_T - or else Base_Type (T) = Base_Type (Act_T)) - and then Subtypes_Statically_Match (T, Act_T)) + return (Base_Type (Base_Type (T)) = Base_Type (Act_T) + and then Subtypes_Statically_Match (T, Act_T)) or else (Is_Class_Wide_Type (Gen_T) and then Is_Class_Wide_Type (Act_T) @@ -13486,7 +13794,7 @@ package body Sem_Ch12 is or else Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private then - -- Check whether the parent is another derived formal type in the + -- Check whether the parent is another formal derived type in the -- same generic unit. if Etype (A_Gen_T) /= A_Gen_T @@ -14178,11 +14486,6 @@ package body Sem_Ch12 is -- Start of processing for Instantiate_Type begin - if Get_Instance_Of (A_Gen_T) /= A_Gen_T then - Error_Msg_N ("duplicate instantiation of generic type", Actual); - return New_List (Error); - end if; - if not Is_Entity_Name (Actual) or else not Is_Type (Entity (Actual)) then @@ -14299,9 +14602,7 @@ package body Sem_Ch12 is Check_Shared_Variable_Control_Aspects; - if Error_Posted (Act_T) then - null; - else + if not Error_Posted (Act_T) then case Nkind (Def) is when N_Formal_Private_Type_Definition => Validate_Private_Type_Instance; @@ -16319,8 +16620,10 @@ package body Sem_Ch12 is -- If there are other defaults, add a dummy association in case -- there are other defaulted formals with the same name. + -- Note that we are creating an N_Generic_Association with + -- neither Explicit_Generic_Actual_Parameter nor Box_Present. - elsif Present (Next (Act2)) then + elsif Present (Next (Act2)) and True then Ndec := Make_Generic_Association (Loc, Selector_Name => diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 6639d54..0356f2a 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -135,7 +135,7 @@ package Sem_Ch12 is -- captured as described here. -- Because instantiations can be nested, the environment of the instance, - -- involving the actuals and other data-structures, must be saved and + -- involving the actuals and other data structures, must be saved and -- restored in stack-like fashion. Front-end inlining also uses these -- structures for the management of private/full views. @@ -186,7 +186,7 @@ package Sem_Ch12 is Act_Unit : Entity_Id); -- Because instantiations can be nested, the compiler maintains a stack -- of environments that holds variables relevant to the current instance: - -- most importanty Instantiated_Parent, Exchanged_Views, Hidden_Entities, + -- most importantly Instantiated_Parent, Exchanged_Views, Hidden_Entities, -- and others (see full list in Instance_Env). procedure Restore_Env; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0e951c1..eebaedc 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1250,7 +1250,8 @@ package body Sem_Ch3 is -- to incomplete types declared in some enclosing scope, not to limited -- views from other packages. - -- Prior to Ada 2012, access to functions can only have in_parameters. + -- Prior to Ada 2012, access to functions parameters must be of mode + -- 'in'. if Present (Formals) then Formal := First_Formal (Desig_Type); |