diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 116 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 196 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 52 |
8 files changed, 210 insertions, 204 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c99021a..51f57e3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2025-11-05 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/35793 + * sem_res.adb (Check_Discriminant_Use): In a constraint context, + check that the discriminant appears alone as a direct name in all + cases and give a consistent error message when it does not. + +2025-11-04 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch3.adb (Analyze_Subtype_Declaration) <Concurrent_Kind>: + Propagate the Uses_Lock_Free flag for protected types. + +2025-11-04 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/18453 + * sem_ch12.adb (Find_Actual_Type): Add Typ_Ref parameter and + perform a standard resolution on it in the fallback case. + Call Get_Instance_Of if the type is declared in a formal of + the child unit. + (Instantiate_Type.Validate_Access_Type_Instance): Adjust call + to Find_Actual_Type. + (Instantiate_Type.Validate_Array_Type_Instance): Likewise and + streamline the check for matching component subtypes. + 2025-11-03 Eric Botcazou <ebotcazou@adacore.com> PR ada/78175 diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index d2f3df8..4e4a6ec 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -117,8 +117,7 @@ package body Exp_Ch2 is procedure Expand_Renaming (N : Node_Id); -- For renamings, just replace the identifier by the corresponding -- named expression. Note that this has been evaluated (see routine - -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives - -- the correct renaming semantics. + -- Exp_Util.Evaluate_Name) so this gives correct renaming semantics. -------------------------- -- Expand_Current_Value -- diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 2ddf75f..3f9dbe8 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -344,22 +344,9 @@ package body Exp_Ch8 is -- Start of processing for Expand_N_Subprogram_Renaming_Declaration begin - -- When the prefix of the name is a function call, we must force the - -- call to be made by removing side effects from the call, since we - -- must only call the function once. + -- Perform name evaluation in all cases - if Nkind (Nam) = N_Selected_Component - and then Nkind (Prefix (Nam)) = N_Function_Call - then - Remove_Side_Effects (Prefix (Nam)); - - -- For an explicit dereference, the prefix must be captured to prevent - -- reevaluation on calls through the renaming, which could result in - -- calling the wrong subprogram if the access value were to be changed. - - elsif Nkind (Nam) = N_Explicit_Dereference then - Force_Evaluation (Prefix (Nam)); - end if; + Evaluate_Name (Nam); -- Handle cases where we build a body for a renamed equality diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 363abe3..b6f5ed0 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 ??? @@ -10465,10 +10467,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 +10484,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 +10501,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; @@ -14596,7 +14594,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 @@ -14685,31 +14684,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 + Dims : constant List_Id + := (if Nkind (Def) = N_Constrained_Array_Definition + then Discrete_Subtype_Definitions (Def) + else Subtype_Marks (Def)); - ----------------------- - -- 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; - - -- 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 @@ -14734,15 +14717,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 @@ -14765,7 +14749,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 &", @@ -14773,34 +14763,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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 233f823..ba0af27 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6145,6 +6145,10 @@ package body Sem_Ch3 is Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); Set_Last_Entity (Id, Last_Entity (T)); + if Is_Protected_Type (T) then + Set_Uses_Lock_Free (Id, Uses_Lock_Free (T)); + end if; + if Is_Tagged_Type (T) then Set_No_Tagged_Streams_Pragma (Id, No_Tagged_Streams_Pragma (T)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5704bf1..54df44d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7147,7 +7147,7 @@ package body Sem_Ch4 is and then N = Prefix (Parent (N)) then Error_Msg_N -- CODEFIX - ("\period should probably be semicolon", Parent (N)); + ("\period is probably a typographical error", Parent (N)); end if; end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fe7f311..11f2b19 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1873,13 +1873,13 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Nam : constant Node_Id := Name (N); - Sel : constant Node_Id := Selector_Name (Nam); - Is_Actual : constant Boolean := Present (Corresponding_Formal_Spec (N)); - Old_S : Entity_Id; + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + + Old_S : Entity_Id; begin - if Entity (Sel) = Any_Id then + if Entity (Selector_Name (Nam)) = Any_Id then -- Selector is undefined on prefix. Error emitted already @@ -1910,10 +1910,11 @@ package body Sem_Ch8 is -- The prefix can be an arbitrary expression that yields a task or -- protected object, so it must be resolved. - if Is_Access_Type (Etype (Prefix (Nam))) then - Insert_Explicit_Dereference (Prefix (Nam)); + if Is_Access_Type (Etype (P)) then + Insert_Explicit_Dereference (P); end if; - Resolve (Prefix (Nam), Scope (Old_S)); + + Resolve (P, Scope (Old_S)); end if; Set_Convention (New_S, Convention (Old_S)); @@ -1924,9 +1925,9 @@ package body Sem_Ch8 is if Is_Protected_Type (Scope (Old_S)) and then Ekind (New_S) = E_Procedure - and then not Is_Variable (Prefix (Nam)) + and then not Is_Variable (P) then - if Is_Actual then + if Present (Corresponding_Formal_Spec (N)) then Error_Msg_N ("target object of protected operation used as actual for " & "formal procedure must be a variable", Nam); @@ -1951,8 +1952,9 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Nam : constant Node_Id := Name (N); - P : constant Node_Id := Prefix (Nam); + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + Old_S : Entity_Id; begin @@ -1995,13 +1997,13 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Old_S : Entity_Id; - Nam : Entity_Id; + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); function Conforms (Subp : Entity_Id; Ctyp : Conformance_Type) return Boolean; - -- Verify that the signatures of the renamed entity and the new entity + -- Verify that the profiles of the renamed entity and the new entity -- match. The first formal of the renamed entity is skipped because it -- is the target object in any subsequent call. @@ -2038,14 +2040,16 @@ package body Sem_Ch8 is Next_Formal (Old_F); end loop; - return True; + return No (Old_F) and then No (New_F); end Conforms; + Old_S : Entity_Id; + -- Start of processing for Analyze_Renamed_Primitive_Operation begin - if not Is_Overloaded (Selector_Name (Name (N))) then - Old_S := Entity (Selector_Name (Name (N))); + if not Is_Overloaded (Selector_Name (Nam)) then + Old_S := Entity (Selector_Name (Nam)); if not Conforms (Old_S, Type_Conformant) then Old_S := Any_Id; @@ -2060,7 +2064,7 @@ package body Sem_Ch8 is begin Old_S := Any_Id; - Get_First_Interp (Selector_Name (Name (N)), Ind, It); + Get_First_Interp (Selector_Name (Nam), Ind, It); while Present (It.Nam) loop if Conforms (It.Nam, Type_Conformant) then @@ -2094,20 +2098,18 @@ package body Sem_Ch8 is -- AI12-0204: The prefix of a prefixed view that is renamed or -- passed as a formal subprogram must be renamable as an object. - Nam := Prefix (Name (N)); - - if Is_Object_Reference (Nam) then - if Is_Dependent_Component_Of_Mutable_Object (Nam) then + if Is_Object_Reference (P) then + if Is_Dependent_Component_Of_Mutable_Object (P) then Error_Msg_N ("illegal renaming of discriminant-dependent component", - Nam); - elsif Depends_On_Mutably_Tagged_Ext_Comp (Nam) then + P); + elsif Depends_On_Mutably_Tagged_Ext_Comp (P) then Error_Msg_N ("illegal renaming of mutably tagged dependent component", - Nam); + P); end if; else - Error_Msg_N ("expect object name in renaming", Nam); + Error_Msg_N ("expect object name in renaming", P); end if; -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed @@ -2119,12 +2121,16 @@ package body Sem_Ch8 is Set_Convention (New_S, Convention_Intrinsic); end if; - -- Inherit_Renamed_Profile (New_S, Old_S); + Set_Entity (Selector_Name (Nam), Old_S); -- The prefix can be an arbitrary expression that yields an -- object, so it must be resolved. - Resolve (Prefix (Name (N))); + if Is_Access_Type (Etype (P)) then + Insert_Explicit_Dereference (P); + end if; + + Resolve (P); end if; end Analyze_Renamed_Primitive_Operation; @@ -8504,92 +8510,104 @@ package body Sem_Ch8 is end; end if; + -- Case of the enclosing construct + if In_Open_Scopes (P_Name) then Set_Entity (P, P_Name); Set_Is_Overloaded (P, False); Find_Expanded_Name (N); + -- If no interpretation as an expanded name is possible, then it + -- must be a selected component of a record returned by a function + -- call. Reformat the prefix as a function call and analyze it. + else - -- If no interpretation as an expanded name is possible, it - -- must be a selected component of a record returned by a - -- function call. Reformat prefix as a function call, the rest - -- is done by type resolution. + declare + procedure Diagnose_Call; + -- Try and give useful diagnostics on error - -- Error if the prefix is procedure or entry, as is P.X + ------------------- + -- Diagnose_Call -- + ------------------- - if Ekind (P_Name) /= E_Function - and then - (not Is_Overloaded (P) - or else Nkind (Parent (N)) = N_Procedure_Call_Statement) - then - -- Prefix may mention a package that is hidden by a local - -- declaration: let the user know. Scan the full homonym - -- chain, the candidate package may be anywhere on it. + procedure Diagnose_Call is + Ent : Entity_Id; - if Present (Homonym (Current_Entity (P_Name))) then - P_Name := Current_Entity (P_Name); + begin + -- Prefix may mention a package that is hidden by a local + -- declaration: let the user know. Scan the full homonym + -- chain, the candidate package may be anywhere on it. - while Present (P_Name) loop - exit when Ekind (P_Name) = E_Package; - P_Name := Homonym (P_Name); + Ent := Current_Entity (P_Name); + + while Present (Ent) loop + exit when Ekind (Ent) = E_Package; + Ent := Homonym (Ent); end loop; - if Present (P_Name) then - if not Is_Reference_In_Subunit then - Error_Msg_Sloc := Sloc (Entity (Prefix (N))); - Error_Msg_NE - ("package& is hidden by declaration#", N, P_Name); - end if; + if Present (Ent) and then not Is_Reference_In_Subunit then + Error_Msg_Sloc := Sloc (P_Name); + Error_Msg_NE + ("\package& is hidden by declaration#", N, Ent); + end if; - Set_Entity (Prefix (N), P_Name); - Find_Expanded_Name (N); - return; + -- Format node as expanded name, to avoid cascaded errors - else - P_Name := Entity (Prefix (N)); - end if; - end if; + Change_Selected_Component_To_Expanded_Name (N); + Set_Entity (N, Any_Id); + Set_Etype (N, Any_Type); + end Diagnose_Call; - Error_Msg_NE - ("invalid prefix in selected component&", N, P_Name); - Change_Selected_Component_To_Expanded_Name (N); - Set_Entity (N, Any_Id); - Set_Etype (N, Any_Type); + begin + -- Error if the prefix is procedure or entry, as in P.X - -- Here we have a function call, so do the reformatting + if Ekind (P_Name) /= E_Function + and then not Is_Overloaded (P) + then + Error_Msg_NE + ("invalid prefix& in selected component", N, P_Name); + Diagnose_Call; + return; - else - Nam := New_Copy (P); - Save_Interps (P, Nam); + -- Here we may have a function call, so do the reformatting + + else + Nam := New_Copy (P); + Save_Interps (P, Nam); - -- We use Replace here because this is one of those cases - -- where the parser has missclassified the node, and we fix - -- things up and then do the semantic analysis on the fixed - -- up node. Normally we do this using one of the Sinfo.CN - -- routines, but this is too tricky for that. + -- We use Replace here because this is one of those cases + -- where the parser has misclassified the node and we fix + -- things up and then do semantic analysis on the fixed + -- up node. Normally we do this using one of the Sinfo.CN + -- routines, but this is too tricky for that. - -- Note that using Rewrite would be wrong, because we would - -- have a tree where the original node is unanalyzed. + -- Note that using Rewrite would be wrong, since we would + -- have a tree where the original node is unanalyzed. - Replace (P, - Make_Function_Call (Sloc (P), Name => Nam)); + Replace (P, Make_Function_Call (Sloc (P), Name => Nam)); - -- Now analyze the reformatted node + -- Now analyze the reformatted node - Analyze_Call (P); + Analyze_Call (P); - -- If the prefix is illegal after this transformation, there - -- may be visibility errors on the prefix. The safest is to - -- treat the selected component as an error. + -- If the prefix is illegal after this transformation, + -- there may be a visibility error on the prefix. The + -- safest is to treat the selected component as an error. - if Error_Posted (P) then - Set_Etype (N, Any_Type); - return; + if Error_Posted (P) then + Diagnose_Call; + return; - else - Analyze_Selected_Component (N); + else + Analyze_Selected_Component (N); + + if Error_Posted (N) then + Diagnose_Call; + return; + end if; + end if; end if; - end if; + end; end if; -- Remaining cases generate various error messages diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bf9d5e1..301894b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -658,6 +658,24 @@ package body Sem_Res is P : Node_Id; D : Node_Id; + procedure Check_Legality_In_Constraint (Alone : Boolean); + -- RM 3.8(12/3): Check that the discriminant mentioned in a constraint + -- appears alone as a direct name. + + ---------------------------------- + -- Check_Legality_In_Constraint -- + ---------------------------------- + + procedure Check_Legality_In_Constraint (Alone : Boolean) is + begin + if not Alone then + Error_Msg_N ("discriminant in constraint must appear alone", N); + + elsif Nkind (N) = N_Expanded_Name and then Comes_From_Source (N) then + Error_Msg_N ("discriminant must appear alone as a direct name", N); + end if; + end Check_Legality_In_Constraint; + begin -- Any use in a spec-expression is legal @@ -694,19 +712,11 @@ package body Sem_Res is -- processing for records). See Sem_Ch3.Build_Derived_Record_Type -- for more info. - if Ekind (Current_Scope) = E_Record_Type - and then Scope (Disc) = Current_Scope - and then not - (Nkind (Parent (P)) = N_Subtype_Indication - and then - Nkind (Parent (Parent (P))) in N_Component_Definition - | N_Subtype_Declaration - and then Paren_Count (N) = 0) - then - Error_Msg_N - ("discriminant must appear alone in component constraint", N); - return; - end if; + Check_Legality_In_Constraint + (Nkind (Parent (P)) = N_Subtype_Indication + and then Nkind (Parent (Parent (P))) in N_Component_Definition + | N_Subtype_Declaration + and then Paren_Count (N) = 0); -- Detect a common error: @@ -817,18 +827,7 @@ package body Sem_Res is elsif Nkind (PN) in N_Index_Or_Discriminant_Constraint | N_Discriminant_Association then - if Paren_Count (N) > 0 then - Error_Msg_N - ("discriminant in constraint must appear alone", N); - - elsif Nkind (N) = N_Expanded_Name - and then Comes_From_Source (N) - then - Error_Msg_N - ("discriminant must appear alone as a direct name", N); - end if; - - return; + Check_Legality_In_Constraint (Paren_Count (N) = 0); -- Otherwise, context is an expression. It should not be within (i.e. a -- subexpression of) a constraint for a component. @@ -863,8 +862,7 @@ package body Sem_Res is or else Nkind (P) = N_Entry_Declaration or else Nkind (D) = N_Defining_Identifier then - Error_Msg_N - ("discriminant in constraint must appear alone", N); + Check_Legality_In_Constraint (False); end if; end if; end Check_Discriminant_Use; |