diff options
| author | Bob Duff <duff@adacore.com> | 2024-05-28 12:19:51 -0400 |
|---|---|---|
| committer | Marc Poulhiès <poulhies@adacore.com> | 2024-06-20 10:50:57 +0200 |
| commit | a688a0281946b1cc11333ca548db031a9aa0e9fd (patch) | |
| tree | 7ecfcacc8b3f13223d48088dd7b4bd26589eebf7 | |
| parent | 36bd57330f9b8f06206c909af53cd8b3ca6f6bed (diff) | |
| download | gcc-a688a0281946b1cc11333ca548db031a9aa0e9fd.zip gcc-a688a0281946b1cc11333ca548db031a9aa0e9fd.tar.gz gcc-a688a0281946b1cc11333ca548db031a9aa0e9fd.tar.bz2 | |
ada: Rewrite generic formal/actual matching
...in preparation for implementing type inference for generic
parameters.
The main change is to do the "matching" computation early, and produce a
*constant* data structure (Gen_Assocs_Rec) to represent the matching
between each triple of unanalyzed formal, analyzed formal, and
corresponding actual. This will allow us to look at that data structure
more than once, which will be necessary for type inference.
Matching_Actual is removed; Match_Assocs is added.
Other changes include removal of global variables, splitting out
processing into subprograms, adding assertions, comment corrections,
and other general cleanups.
gcc/ada/
* expander.ads: Minor comment fixes.
* nlists.ads: Misc comment improvements.
* sem_aux.ads (First_Discriminant): Improve comment.
* sem_ch12.adb: Misc cleanups.
(Associations): New package containing type Gen_Assocs_Rec
to represent matchings, and function Match_Assocs to create the
Gen_Assocs_Rec constant.
(Analyze_Associations): Call Match_Assocs, and other major
changes related to that.
* sem_ch12.ads: Minor comment fixes.
* sem_ch3.adb: Minor comment fixes.
| -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); |