diff options
Diffstat (limited to 'gcc/ada/sem_ch12.adb')
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 257 |
1 files changed, 118 insertions, 139 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 702939a..750c2c1 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -642,8 +642,9 @@ package body Sem_Ch12 is -- of freeze nodes for instance bodies that may depend on other instances. function Find_Actual_Type - (Typ : Entity_Id; - Gen_Type : Entity_Id) return Entity_Id; + (Typ : Entity_Id; + Gen_Type : Entity_Id; + Typ_Ref : Node_Id) return Entity_Id; -- When validating the actual types of a child instance, check whether -- the formal is a formal type of the parent unit, and retrieve the current -- actual for it. Typ is the entity in the analyzed formal type declaration @@ -653,7 +654,8 @@ package body Sem_Ch12 is -- be declared in a formal package of a parent. In both cases it is a -- generic actual type because it appears within a visible instance. -- Finally, it may be declared in a parent unit without being a formal - -- of that unit, in which case it must be retrieved by visibility. + -- of that unit, in which case it must be retrieved by visibility and + -- Typ_Ref is the unanalyzed subtype mark in the instance to be used. -- Ambiguities may still arise if two homonyms are declared in two formal -- packages, and the prefix of the formal type may be needed to resolve -- the ambiguity in the instance ??? @@ -810,11 +812,11 @@ package body Sem_Ch12 is -- the suffix is removed is added to Prims_List to restore them later. procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); - -- When compiling an instance of a child unit the parent (which is - -- itself an instance) is an enclosing scope that must be made - -- immediately visible. This procedure is also used to install the non- - -- generic parent of a generic child unit when compiling its body, so - -- that full views of types in the parent are made visible. + -- When compiling an instance of a child unit, the parent P is an enclosing + -- scope that must be made immediately visible. In_Body is True if this is + -- done for an instance body and False for an instance spec. Note that the + -- procedure does not insert P on the scope stack above the current scope, + -- but instead pushes P and then pushes an extra copy of the current scope. -- The functions Instantiate_... perform various legality checks and build -- the declarations for instantiated generic parameters. In all of these @@ -930,7 +932,7 @@ package body Sem_Ch12 is -- subprogram declaration N. procedure Remove_Parent (In_Body : Boolean := False); - -- Reverse effect after instantiation of child is complete + -- Reverse Install_Parent's 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 @@ -4880,25 +4882,38 @@ package body Sem_Ch12 is ------------------------------- function Needs_Body_Instantiated (Gen_Unit : Entity_Id) return Boolean is + S : constant Entity_Id := Scope (Gen_Unit); + begin + -- If the generic package being instantiated is declared within + -- a formal package, and we are in the context of the enclosing + -- generic unit of the formal package, then there is no body to + -- instantiate until the enclosing generic unit is instantiated + -- with an actual for the formal package. + + if Is_Generic_Instance (S) + and then + Nkind (Original_Node (Unit_Declaration_Node (S))) = + N_Formal_Package_Declaration + and then In_Open_Scopes (Scope (S)) + then + return False; + -- If the instantiation is in the auxiliary declarations of the main -- unit, then the body is needed, even if the main unit is generic. - if Parent (N) = Aux_Decls_Node (Cunit (Main_Unit)) then + elsif Parent (N) = Aux_Decls_Node (Cunit (Main_Unit)) then return True; - end if; -- No need to instantiate bodies in generic units - if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then + elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then return False; - end if; -- If the instantiation is in the main unit, then the body is needed - if Is_In_Main_Unit (N) then + elsif Is_In_Main_Unit (N) then return True; - end if; -- In GNATprove mode, never instantiate bodies outside of the main -- unit, as it does not use frontend/backend inlining in the way that @@ -4906,15 +4921,13 @@ package body Sem_Ch12 is -- contrary, such instantiations may bring artificial constraints, -- as for example such bodies may require preprocessing. - if GNATprove_Mode then + elsif GNATprove_Mode then return False; - end if; -- If not, then again no need to instantiate bodies in generic units - if Is_Generic_Unit (Cunit_Entity (Get_Code_Unit (N))) then + elsif Is_Generic_Unit (Cunit_Entity (Get_Code_Unit (N))) then return False; - end if; -- Here we have a special handling for back-end inlining: if inline -- processing is required, then we unconditionally want to have the @@ -4924,14 +4937,15 @@ package body Sem_Ch12 is -- these instantiations are only performed on demand when back-end -- inlining is enabled, so this causes very little extra work. - if Inline_Processing_Required and then Back_End_Inlining then + elsif Inline_Processing_Required and then Back_End_Inlining then return True; - end if; -- We want to have the bodies instantiated in non-main units if -- they might contribute inlined subprograms. - return Might_Inline_Subp (Gen_Unit); + else + return Might_Inline_Subp (Gen_Unit); + end if; end Needs_Body_Instantiated; -- Local declarations @@ -5412,43 +5426,6 @@ package body Sem_Ch12 is and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then GNATprove_Mode)); - - -- If front-end inlining is enabled or there are any subprograms - -- marked with Inline_Always, do not instantiate body when within - -- a generic context. - - if not Back_End_Inlining - and then (Front_End_Inlining or else Has_Inline_Always) - and then not Expander_Active - then - Needs_Body := False; - end if; - - -- If the current context is generic, and the package being - -- instantiated is declared within a formal package, there is no - -- body to instantiate until the enclosing generic is instantiated - -- and there is an actual for the formal package. If the formal - -- package has parameters, we build a regular package instance for - -- it, that precedes the original formal package declaration. - - if In_Open_Scopes (Scope (Scope (Gen_Unit))) then - declare - Decl : constant Node_Id := - Original_Node - (Unit_Declaration_Node (Scope (Gen_Unit))); - begin - if Nkind (Decl) = N_Formal_Package_Declaration - or else (Nkind (Decl) = N_Package_Declaration - and then Is_List_Member (Decl) - and then Present (Next (Decl)) - and then - Nkind (Next (Decl)) = - N_Formal_Package_Declaration) - then - Needs_Body := False; - end if; - end; - end if; end; -- For RCI unit calling stubs, we omit the instance body if the @@ -10465,10 +10442,10 @@ package body Sem_Ch12 is function Find_Actual_Type (Typ : Entity_Id; - Gen_Type : Entity_Id) return Entity_Id + Gen_Type : Entity_Id; + Typ_Ref : Node_Id) return Entity_Id is Gen_Scope : constant Entity_Id := Scope (Gen_Type); - T : Entity_Id; begin -- Special processing only applies to child units @@ -10482,6 +10459,12 @@ package body Sem_Ch12 is elsif Scope (Typ) = Gen_Scope then return Get_Instance_Of (Typ); + -- If designated or component type is declared in a formal of the child + -- unit, its instance is available. + + elsif Scope (Scope (Typ)) = Gen_Scope then + return Get_Instance_Of (Typ); + -- If the array or access type is not declared in the parent unit, -- no special processing needed. @@ -10493,18 +10476,8 @@ package body Sem_Ch12 is -- Otherwise, retrieve designated or component type by visibility else - T := Current_Entity (Typ); - while Present (T) loop - if In_Open_Scopes (Scope (T)) then - return T; - elsif Is_Generic_Actual_Type (T) then - return T; - end if; - - T := Homonym (T); - end loop; - - return Typ; + Analyze (Typ_Ref); + return Entity (Typ_Ref); end if; end Find_Actual_Type; @@ -11168,10 +11141,20 @@ package body Sem_Ch12 is ------------------------ procedure Hide_Current_Scope is - C : constant Entity_Id := Current_Scope; + C : Entity_Id; E : Entity_Id; begin + C := Current_Scope; + + -- The analysis of the actual parameters may have created a transient + -- scope after the extra copy of the current scope was pushed onto the + -- stack, so we need to skip it. + + if Scope_Is_Transient then + C := Scope (C); + end if; + Set_Is_Hidden_Open_Scope (C); E := First_Entity (C); @@ -11194,7 +11177,6 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (C, False); Append_Elmt (C, Hidden_Entities); end if; - end Hide_Current_Scope; -------------- @@ -14587,7 +14569,8 @@ package body Sem_Ch12 is procedure Validate_Access_Type_Instance is Desig_Type : constant Entity_Id := - Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); + Find_Actual_Type + (Designated_Type (A_Gen_T), A_Gen_T, Subtype_Indication (Def)); Desig_Act : Entity_Id; begin @@ -14676,31 +14659,15 @@ package body Sem_Ch12 is ---------------------------------- procedure Validate_Array_Type_Instance is - I1 : Node_Id; - I2 : Node_Id; - T2 : Entity_Id; - - function Formal_Dimensions return Nat; - -- Count number of dimensions in array type formal - - ----------------------- - -- Formal_Dimensions -- - ----------------------- - - function Formal_Dimensions return Nat is - Dims : List_Id; - - begin - if Nkind (Def) = N_Constrained_Array_Definition then - Dims := Discrete_Subtype_Definitions (Def); - else - Dims := Subtype_Marks (Def); - end if; - - return List_Length (Dims); - end Formal_Dimensions; + Dims : constant List_Id + := (if Nkind (Def) = N_Constrained_Array_Definition + then Discrete_Subtype_Definitions (Def) + else Subtype_Marks (Def)); - -- Start of processing for Validate_Array_Type_Instance + Dim : Node_Id; + I1 : Node_Id; + I2 : Node_Id; + T2 : Entity_Id; begin if not Is_Array_Type (Act_T) then @@ -14725,15 +14692,16 @@ package body Sem_Ch12 is end if; end if; - if Formal_Dimensions /= Number_Dimensions (Act_T) then + if List_Length (Dims) /= Number_Dimensions (Act_T) then Error_Msg_NE ("dimensions of actual do not match formal &", Actual, Gen_T); Abandon_Instantiation (Actual); end if; - I1 := First_Index (A_Gen_T); - I2 := First_Index (Act_T); - for J in 1 .. Formal_Dimensions loop + Dim := First (Dims); + I1 := First_Index (A_Gen_T); + I2 := First_Index (Act_T); + for J in 1 .. List_Length (Dims) loop -- If the indexes of the actual were given by a subtype_mark, -- the index was transformed into a range attribute. Retrieve @@ -14756,7 +14724,13 @@ package body Sem_Ch12 is end if; if not Subtypes_Match - (Find_Actual_Type (Etype (I1), A_Gen_T), T2) + (Find_Actual_Type + (Etype (I1), + A_Gen_T, + (if Nkind (Dim) = N_Subtype_Indication + then Subtype_Mark (Dim) + else Dim)), + T2) then Error_Msg_NE ("index types of actual do not match those of formal &", @@ -14764,34 +14738,20 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Next (Dim); Next_Index (I1); Next_Index (I2); end loop; - -- Check matching subtypes. Note that there are complex visibility - -- issues when the generic is a child unit and some aspect of the - -- generic type is declared in a parent unit of the generic. We do - -- the test to handle this special case only after a direct check - -- for static matching has failed. The case where both the component - -- type and the array type are separate formals, and the component - -- type is a private view may also require special checking in - -- Subtypes_Match. Finally, we assume that a child instance where - -- the component type comes from a formal of a parent instance is - -- correct because the generic was correct. A more precise check - -- seems too complex to install??? - - if Subtypes_Match - (Component_Type (A_Gen_T), Component_Type (Act_T)) - or else - Subtypes_Match - (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), - Component_Type (Act_T)) - or else - (not Inside_A_Generic - and then Is_Child_Unit (Scope (Component_Type (A_Gen_T)))) + -- Check matching component subtypes + + if not Subtypes_Match + (Find_Actual_Type + (Component_Type (A_Gen_T), + A_Gen_T, + Subtype_Indication (Component_Definition (Def))), + Component_Type (Act_T)) then - null; - else Error_Msg_NE ("component subtype of actual does not match that of formal &", Actual, Gen_T); @@ -15834,7 +15794,7 @@ package body Sem_Ch12 is Diagnose_Predicated_Actual; when N_Formal_Signed_Integer_Type_Definition => - if not Is_Signed_Integer_Type (Act_T) then + if not Has_Overflow_Operations (Act_T) then Error_Msg_NE ("expect signed integer type in instantiation of&", Actual, Gen_T); @@ -15844,7 +15804,7 @@ package body Sem_Ch12 is Diagnose_Predicated_Actual; when N_Formal_Modular_Type_Definition => - if not Is_Modular_Integer_Type (Act_T) then + if not Has_Modular_Operations (Act_T) then Error_Msg_NE ("expect modular type in instantiation of &", Actual, Gen_T); @@ -16948,20 +16908,33 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False) is S : Entity_Id := Current_Scope; - -- S is the scope containing the instantiation just completed. The scope - -- stack contains the parent instances of the instantiation, followed by - -- the original S. + -- S is the extra copy of the current scope that has been pushed by + -- Install_Parent. The scope stack next contains the parents of the + -- instance followed by the original S. Cur_P : Entity_Id; E : Entity_Id; - P : Entity_Id; Hidden : Elmt_Id; + P : Entity_Id; + SE : Scope_Stack_Entry; begin - -- After child instantiation is complete, remove from scope stack the - -- extra copy of the current scope, and then remove parent instances. - if not In_Body then + -- If the analysis of the actual parameters has created a transient + -- scope after the extra copy of the current scope was pushed onto + -- the stack, we first need to save this transient scope and pop it. + + if Scope_Is_Transient then + SE := Scope_Stack.Table (Scope_Stack.Last); + Scope_Stack.Decrement_Last; + S := Current_Scope; + else + SE.Is_Transient := False; + end if; + + -- After child instantiation is complete, remove from scope stack the + -- extra copy of the current scope, and then remove the parents. + Pop_Scope; while Current_Scope /= S loop @@ -17045,6 +17018,12 @@ package body Sem_Ch12 is Next_Elmt (Hidden); end loop; + -- Restore the transient scope that was popped on entry, if any + + if SE.Is_Transient then + Scope_Stack.Append (SE); + end if; + else -- Each body is analyzed separately, and there is no context that -- needs preserving from one body instance to the next, so remove all @@ -19251,13 +19230,13 @@ package body Sem_Ch12 is end if; when N_Formal_Signed_Integer_Type_Definition => - if not Is_Integer_Type (Def_Sub) then + if not Has_Overflow_Operations (Def_Sub) then Error_Msg_NE ("default for& must be a discrete type", Default, Formal); end if; when N_Formal_Modular_Type_Definition => - if not Is_Modular_Integer_Type (Def_Sub) then + if not Has_Modular_Operations (Def_Sub) then Error_Msg_NE ("default for& must be a modular_integer Type", Default, Formal); end if; |