diff options
Diffstat (limited to 'gcc/ada/sem_ch5.adb')
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 457 |
1 files changed, 381 insertions, 76 deletions
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 04fc980..7a8d0cc 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,44 +23,49 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -with Errout; use Errout; -with Expander; use Expander; -with Exp_Ch6; use Exp_Ch6; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Case; use Sem_Case; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Elab; use Sem_Elab; -with Sem_Eval; use Sem_Eval; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Snames; use Snames; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Ttypes; use Ttypes; -with Uintp; use Uintp; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; package body Sem_Ch5 is @@ -475,12 +480,11 @@ package body Sem_Ch5 is Mark_And_Set_Ghost_Assignment (N); if Has_Target_Names (N) then + pragma Assert (No (Current_Assignment)); Current_Assignment := N; Expander_Mode_Save_And_Set (False); Save_Full_Analysis := Full_Analysis; Full_Analysis := False; - else - Current_Assignment := Empty; end if; Analyze (Lhs); @@ -975,7 +979,92 @@ package body Sem_Ch5 is end if; if Is_Scalar_Type (T1) then - Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); + declare + + function Omit_Range_Check_For_Streaming return Boolean; + -- Return True if this assignment statement is the expansion of + -- a Some_Scalar_Type'Read procedure call such that all conditions + -- of 13.3.2(35)'s "no check is made" rule are met. + + ------------------------------------ + -- Omit_Range_Check_For_Streaming -- + ------------------------------------ + + function Omit_Range_Check_For_Streaming return Boolean is + begin + -- Have we got an implicitly generated assignment to a + -- component of a composite object? If not, return False. + + if Comes_From_Source (N) + or else Serious_Errors_Detected > 0 + or else Nkind (Lhs) + not in N_Selected_Component | N_Indexed_Component + then + return False; + end if; + + declare + Pref : constant Node_Id := Prefix (Lhs); + begin + -- Are we in the implicitly-defined Read subprogram + -- for a composite type, reading the value of a scalar + -- component from the stream? If not, return False. + + if Nkind (Pref) /= N_Identifier + or else not Is_TSS (Scope (Entity (Pref)), TSS_Stream_Read) + then + return False; + end if; + + -- Return False if Default_Value or Default_Component_Value + -- aspect applies. + + if Has_Default_Aspect (Etype (Lhs)) + or else Has_Default_Aspect (Etype (Pref)) + then + return False; + + -- Are we assigning to a record component (as opposed to + -- an array component)? + + elsif Nkind (Lhs) = N_Selected_Component then + + -- Are we assigning to a nondiscriminant component + -- that lacks a default initial value expression? + -- If so, return True. + + declare + Comp_Id : constant Entity_Id := + Original_Record_Component + (Entity (Selector_Name (Lhs))); + begin + if Ekind (Comp_Id) = E_Component + and then Nkind (Parent (Comp_Id)) + = N_Component_Declaration + and then + not Present (Expression (Parent (Comp_Id))) + then + return True; + end if; + return False; + end; + + -- We are assigning to a component of an array + -- (and we tested for both Default_Value and + -- Default_Component_Value above), so return True. + + else + pragma Assert (Nkind (Lhs) = N_Indexed_Component); + return True; + end if; + end; + end Omit_Range_Check_For_Streaming; + + begin + if not Omit_Range_Check_For_Streaming then + Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); + end if; + end; -- For array types, verify that lengths match. If the right hand side -- is a function call that has been inlined, the assignment has been @@ -1108,6 +1197,12 @@ package body Sem_Ch5 is -- warnings when an assignment is rewritten as another -- assignment, and gets tied up with itself. + -- We also omit the warning if the RHS includes target names, + -- that is to say the Ada 2022 "@" that denotes an instance of + -- the LHS, which indicates that the current value is being + -- used. Note that this implicit reference to the entity on + -- the RHS is not treated as a source reference. + -- There may have been a previous reference to a component of -- the variable, which in general removes the Last_Assignment -- field of the variable to indicate a relevant use of the @@ -1126,6 +1221,7 @@ package body Sem_Ch5 is and then Comes_From_Source (N) and then In_Extended_Main_Source_Unit (Ent) and then not Has_Deferred_Reference (Ent) + and then not Has_Target_Names (N) then Warn_On_Useless_Assignment (Ent, N); end if; @@ -1205,6 +1301,7 @@ package body Sem_Ch5 is if Has_Target_Names (N) then Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; + Current_Assignment := Empty; end if; pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); @@ -1308,7 +1405,11 @@ package body Sem_Ch5 is Set_Identifier (N, Empty); else - Set_Ekind (Ent, E_Block); + if Ekind (Ent) = E_Label then + Reinit_Field_To_Zero (Ent, F_Enclosing_Scope); + end if; + + Mutate_Ekind (Ent, E_Block); Generate_Reference (Ent, N, ' '); Generate_Definition (Ent); @@ -1397,6 +1498,9 @@ package body Sem_Ch5 is -- the case statement, and as a result it is not a good idea to output -- warning messages about unreachable code. + Is_General_Case_Statement : Boolean := False; + -- Set True (later) if type of case expression is not discrete + procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when the -- case statement has a non static choice. @@ -1438,6 +1542,12 @@ package body Sem_Ch5 is Ent : Entity_Id; begin + if Is_General_Case_Statement then + return; + -- Processing deferred in this case; decls associated with + -- pattern match bindings don't exist yet. + end if; + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; Statements_Analyzed := True; @@ -1456,7 +1566,7 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Is_Assignable (Ent) then + if Is_Object (Ent) then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr and then Compile_Time_Known_Value (First (Choices)) @@ -1475,7 +1585,7 @@ package body Sem_Ch5 is end if; end if; - -- Case where expression is not an entity name of a variable + -- Case where expression is not an entity name of an object Analyze_Statements (Statements (Alternative)); end Process_Statements; @@ -1509,9 +1619,37 @@ package body Sem_Ch5 is and then Present (Full_View (Etype (Exp))) and then Is_Discrete_Type (Full_View (Etype (Exp))) then - Resolve (Exp, Etype (Exp)); + Resolve (Exp); Exp_Type := Full_View (Etype (Exp)); + -- For Ada, overloading might be ok because subsequently filtering + -- out non-discretes may resolve the ambiguity. + -- But GNAT extensions allow casing on non-discretes. + + elsif Extensions_Allowed and then Is_Overloaded (Exp) then + + -- It would be nice if we could generate all the right error + -- messages by calling "Resolve (Exp, Any_Type);" in the + -- same way that they are generated a few lines below by the + -- call "Analyze_And_Resolve (Exp, Any_Discrete);". + -- Unfortunately, Any_Type and Any_Discrete are not treated + -- consistently (specifically, by Sem_Type.Covers), so that + -- doesn't work. + + Error_Msg_N + ("selecting expression of general case statement is ambiguous", + Exp); + return; + + -- Check for a GNAT-extension "general" case statement (i.e., one where + -- the type of the selecting expression is not discrete). + + elsif Extensions_Allowed + and then not Is_Discrete_Type (Etype (Exp)) + then + Resolve (Exp, Etype (Exp)); + Exp_Type := Etype (Exp); + Is_General_Case_Statement := True; else Analyze_And_Resolve (Exp, Any_Discrete); Exp_Type := Etype (Exp); @@ -1564,6 +1702,21 @@ package body Sem_Ch5 is Analyze_Choices (Alternatives (N), Exp_Type); Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); + if Is_General_Case_Statement then + -- Work normally done in Process_Statements was deferred; do that + -- deferred work now that Check_Choices has had a chance to create + -- any needed pattern-match-binding declarations. + declare + Alt : Node_Id := First (Alternatives (N)); + begin + while Present (Alt) loop + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; + Analyze_Statements (Statements (Alt)); + Next (Alt); + end loop; + end; + end if; + if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); end if; @@ -1758,6 +1911,18 @@ package body Sem_Ch5 is raise Program_Error; end Analyze_Goto_Statement; + --------------------------------- + -- Analyze_Goto_When_Statement -- + --------------------------------- + + procedure Analyze_Goto_When_Statement (N : Node_Id) is + begin + -- Verify the condition is a Boolean expression + + Analyze_And_Resolve (Condition (N), Any_Boolean); + Check_Unset_Reference (Condition (N)); + end Analyze_Goto_When_Statement; + -------------------------- -- Analyze_If_Statement -- -------------------------- @@ -1955,7 +2120,7 @@ package body Sem_Ch5 is Id : constant Node_Id := Defining_Identifier (N); begin Enter_Name (Id); - Set_Ekind (Id, E_Label); + Mutate_Ekind (Id, E_Label); Set_Etype (Id, Standard_Void_Type); Set_Enclosing_Scope (Id, Current_Scope); end Analyze_Implicit_Label_Declaration; @@ -2011,9 +2176,11 @@ package body Sem_Ch5 is -- indicator, verify that the container type has an Iterate aspect that -- implements the reversible iterator interface. - procedure Check_Subtype_Indication (Comp_Type : Entity_Id); + procedure Check_Subtype_Definition (Comp_Type : Entity_Id); -- If a subtype indication is present, verify that it is consistent -- with the component type of the array or container name. + -- In Ada 2022, the subtype indication may be an access definition, + -- if the array or container has elements of an anonymous access type. function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id; -- For containers with Iterator and related aspects, the cursor is @@ -2037,31 +2204,53 @@ package body Sem_Ch5 is then null; else - Error_Msg_NE - ("container type does not support reverse iteration", N, Typ); + Error_Msg_N + ("container type does not support reverse iteration", N); end if; end if; end Check_Reverse_Iteration; ------------------------------- - -- Check_Subtype_Indication -- + -- Check_Subtype_Definition -- ------------------------------- - procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is + procedure Check_Subtype_Definition (Comp_Type : Entity_Id) is begin - if Present (Subt) - and then (not Covers (Base_Type ((Bas)), Comp_Type) + if not Present (Subt) then + return; + end if; + + if Is_Anonymous_Access_Type (Entity (Subt)) then + if not Is_Anonymous_Access_Type (Comp_Type) then + Error_Msg_NE + ("component type& is not an anonymous access", + Subt, Comp_Type); + + elsif not Conforming_Types + (Designated_Type (Entity (Subt)), + Designated_Type (Comp_Type), + Fully_Conformant) + then + Error_Msg_NE + ("subtype indication does not match component type&", + Subt, Comp_Type); + end if; + + elsif Present (Subt) + and then (not Covers (Base_Type (Bas), Comp_Type) or else not Subtypes_Statically_Match (Bas, Comp_Type)) then if Is_Array_Type (Typ) then - Error_Msg_N - ("subtype indication does not match component type", Subt); + Error_Msg_NE + ("subtype indication does not match component type&", + Subt, Comp_Type); else - Error_Msg_N - ("subtype indication does not match element type", Subt); + Error_Msg_NE + ("subtype indication does not match element type&", + Subt, Comp_Type); end if; end if; - end Check_Subtype_Indication; + end Check_Subtype_Definition; --------------------- -- Get_Cursor_Type -- @@ -2123,6 +2312,39 @@ package body Sem_Ch5 is Analyze (Decl); Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); end; + + -- Ada 2022: the subtype definition may be for an anonymous + -- access type. + + elsif Nkind (Subt) = N_Access_Definition then + declare + S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S'); + Decl : Node_Id; + begin + if Present (Subtype_Mark (Subt)) then + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => S, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Copy_Tree (Subtype_Mark (Subt)))); + + else + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => S, + Type_Definition => + New_Copy_Tree + (Access_To_Subprogram_Definition (Subt))); + end if; + + Insert_Before (Parent (Parent (N)), Decl); + Analyze (Decl); + Freeze_Before (First (Statements (Parent (Parent (N)))), S); + Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); + end; else Analyze (Subt); end if; @@ -2149,7 +2371,7 @@ package body Sem_Ch5 is -- Set the kind of the loop variable, which is not visible within the -- iterator name. - Set_Ekind (Def_Id, E_Variable); + Mutate_Ekind (Def_Id, E_Variable); -- Provide a link between the iterator variable and the container, for -- subsequent use in cross-reference and modification information. @@ -2360,7 +2582,7 @@ package body Sem_Ch5 is -- Domain of iteration is not overloaded else - Resolve (Iter_Name, Etype (Iter_Name)); + Resolve (Iter_Name); end if; if not Of_Present (N) then @@ -2400,7 +2622,7 @@ package body Sem_Ch5 is & "component of a mutable object", N); end if; - Check_Subtype_Indication (Component_Type (Typ)); + Check_Subtype_Definition (Component_Type (Typ)); -- Here we have a missing Range attribute @@ -2418,7 +2640,7 @@ package body Sem_Ch5 is -- Prevent cascaded errors - Set_Ekind (Def_Id, E_Loop_Parameter); + Mutate_Ekind (Def_Id, E_Loop_Parameter); Set_Etype (Def_Id, Etype (First_Index (Typ))); end if; @@ -2430,7 +2652,7 @@ package body Sem_Ch5 is -- Iteration over a container else - Set_Ekind (Def_Id, E_Loop_Parameter); + Mutate_Ekind (Def_Id, E_Loop_Parameter); Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N)); -- OF present @@ -2450,7 +2672,7 @@ package body Sem_Ch5 is end if; end; - Check_Subtype_Indication (Etype (Def_Id)); + Check_Subtype_Definition (Etype (Def_Id)); -- For a predefined container, the type of the loop variable is -- the Iterator_Element aspect of the container type. @@ -2477,13 +2699,13 @@ package body Sem_Ch5 is Cursor_Type := Get_Cursor_Type (Typ); pragma Assert (Present (Cursor_Type)); - Check_Subtype_Indication (Etype (Def_Id)); + Check_Subtype_Definition (Etype (Def_Id)); -- If the container has a variable indexing aspect, the -- element is a variable and is modifiable in the loop. if Has_Aspect (Typ, Aspect_Variable_Indexing) then - Set_Ekind (Def_Id, E_Variable); + Mutate_Ekind (Def_Id, E_Variable); end if; -- If the container is a constant, iterating over it @@ -2654,7 +2876,7 @@ package body Sem_Ch5 is procedure Analyze_Label_Entity (E : Entity_Id) is begin - Set_Ekind (E, E_Label); + Mutate_Ekind (E, E_Label); Set_Etype (E, Standard_Void_Type); Set_Enclosing_Scope (E, Current_Scope); Set_Reachable (E, True); @@ -3040,7 +3262,7 @@ package body Sem_Ch5 is -- subsequent analysis of the condition in a quantified -- expression. - Set_Ekind (Id, E_Loop_Parameter); + Mutate_Ekind (Id, E_Loop_Parameter); return; end; @@ -3103,7 +3325,7 @@ package body Sem_Ch5 is Make_Index (DS, N); end if; - Set_Ekind (Id, E_Loop_Parameter); + Mutate_Ekind (Id, E_Loop_Parameter); -- A quantified expression which appears in a pre- or post-condition may -- be analyzed multiple times. The analysis of the range creates several @@ -3298,6 +3520,32 @@ package body Sem_Ch5 is ("\loop executes zero times or raises " & "Constraint_Error??", Bad_Bound); end if; + + if Compile_Time_Compare (LLo, LHi, Assume_Valid => False) + = GT + then + Error_Msg_N ("??constrained range is null", + Constraint (DS)); + + -- Additional constraints on modular types can be + -- confusing, add more information. + + if Ekind (Etype (DS)) = E_Modular_Integer_Subtype then + Error_Msg_Uint_1 := Intval (LLo); + Error_Msg_Uint_2 := Intval (LHi); + Error_Msg_NE ("\iterator has modular type &, " & + "so the loop has bounds ^ ..^", + Constraint (DS), + Subtype_Mark (DS)); + end if; + + Set_Is_Null_Loop (Loop_Nod); + Null_Range := True; + + -- Suppress other warnigns about the body of the loop, as + -- it will never execute. + Set_Suppress_Loop_Warnings (Loop_Nod); + end if; end; end if; @@ -3731,7 +3979,7 @@ package body Sem_Ch5 is and then Ekind (Homonym (Ent)) = E_Label then Set_Entity (Id, Ent); - Set_Ekind (Ent, E_Loop); + Mutate_Ekind (Ent, E_Loop); end if; else @@ -3745,7 +3993,8 @@ package body Sem_Ch5 is -- parser for generic units. if Ekind (Ent) = E_Label then - Set_Ekind (Ent, E_Loop); + Reinit_Field_To_Zero (Ent, F_Enclosing_Scope); + Mutate_Ekind (Ent, E_Loop); if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then Set_Label_Construct (Parent (Ent), N); @@ -3909,7 +4158,7 @@ package body Sem_Ch5 is if not Of_Present (I_Spec) or else not Is_Variable (Name (I_Spec)) then - Set_Ekind (Id, E_Loop_Parameter); + Mutate_Ekind (Id, E_Loop_Parameter); end if; end; @@ -3984,11 +4233,67 @@ package body Sem_Ch5 is ------------------------- procedure Analyze_Target_Name (N : Node_Id) is + procedure Report_Error; + -- Complain about illegal use of target_name and rewrite it into unknown + -- identifier. + + ------------------ + -- Report_Error -- + ------------------ + + procedure Report_Error is + begin + Error_Msg_N + ("must appear in the right-hand side of an assignment statement", + N); + Rewrite (N, New_Occurrence_Of (Any_Id, Sloc (N))); + end Report_Error; + + -- Start of processing for Analyze_Target_Name + begin -- A target name has the type of the left-hand side of the enclosing -- assignment. - Set_Etype (N, Etype (Name (Current_Assignment))); + -- First, verify that the context is the right-hand side of an + -- assignment statement. + + if No (Current_Assignment) then + Report_Error; + return; + end if; + + declare + Current : Node_Id := N; + Context : Node_Id := Parent (N); + begin + while Present (Context) loop + + -- Check if target_name appears in the expression of the enclosing + -- assignment. + + if Nkind (Context) = N_Assignment_Statement then + if Current = Expression (Context) then + pragma Assert (Context = Current_Assignment); + Set_Etype (N, Etype (Name (Current_Assignment))); + else + Report_Error; + end if; + return; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Context) then + Report_Error; + return; + end if; + + Current := Context; + Context := Parent (Context); + end loop; + + Report_Error; + end; end Analyze_Target_Name; ------------------------ @@ -4337,8 +4642,8 @@ package body Sem_Ch5 is Error_Msg_N ("ambiguous bounds in range of iteration", R_Copy); Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\\} ", R_Copy, Found); - Error_Msg_NE ("\\} ", R_Copy, It.Typ); + Error_Msg_NE ("\\}", R_Copy, Found); + Error_Msg_NE ("\\}", R_Copy, It.Typ); exit; end if; end if; |