From d43584ca123f03c24aa7e59a43ecf2bd3a6e4863 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Jan 2017 12:54:05 +0100 Subject: [PATCH] [multiple changes] 2017-01-23 Hristian Kirtchev * exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb, sem_ch3.adb, sem_ch5.adb, sem_ch5.ads, sem_util.adb, sinfo.ads: Minor reformatting. * exp_ch9.adb: minor style fix in comment. 2017-01-23 Ed Schonberg * sem_ch4.adb (Analyze_Allocator): Handle properly a type derived for a limited record extension with unknown discriminants whose full view has no discriminants. 2017-01-23 Yannick Moy * exp_spark.adb: Alphabetize with clauses. From-SVN: r244788 --- gcc/ada/ChangeLog | 17 ++++ gcc/ada/exp_ch5.adb | 179 ++++++++++++++++++++++++------------------ gcc/ada/exp_ch9.adb | 2 +- gcc/ada/exp_spark.adb | 6 +- gcc/ada/freeze.adb | 6 +- gcc/ada/par-ch4.adb | 13 +-- gcc/ada/scng.adb | 4 +- gcc/ada/sem_ch13.adb | 160 ++++++++++++++++++------------------- gcc/ada/sem_ch3.adb | 11 ++- gcc/ada/sem_ch4.adb | 17 ++++ gcc/ada/sem_ch5.adb | 8 +- gcc/ada/sem_ch5.ads | 2 +- gcc/ada/sem_util.adb | 17 ++-- gcc/ada/sinfo.ads | 8 +- 14 files changed, 255 insertions(+), 195 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 86e43ef0a3b..c28e5af6b9b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2017-01-23 Hristian Kirtchev + + * exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch5.adb, sem_ch5.ads, sem_util.adb, sinfo.ads: Minor + reformatting. + * exp_ch9.adb: minor style fix in comment. + +2017-01-23 Ed Schonberg + + * sem_ch4.adb (Analyze_Allocator): Handle properly a type derived + for a limited record extension with unknown discriminants whose + full view has no discriminants. + +2017-01-23 Yannick Moy + + * exp_spark.adb: Alphabetize with clauses. + 2017-01-23 Yannick Moy * sem_util.adb (Has_Enabled_Property): Treat diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 17233c2554a..6a808a35a30 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -75,15 +75,15 @@ package body Exp_Ch5 is -- of formal container iterators. function Change_Of_Representation (N : Node_Id) return Boolean; - -- Determine if the right hand side of assignment N is a type conversion + -- Determine if the right-hand side of assignment N is a type conversion -- which requires a change of representation. Called only for the array -- and record cases. procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); -- N is an assignment which assigns an array value. This routine process -- the various special cases and checks required for such assignments, - -- including change of representation. Rhs is normally simply the right - -- hand side of the assignment, except that if the right hand side is a + -- including change of representation. Rhs is normally simply the right- + -- hand side of the assignment, except that if the right-hand side is a -- type conversion or a qualified expression, then the RHS is the actual -- expression inside any such type conversions or qualifications. @@ -98,14 +98,14 @@ package body Exp_Ch5 is -- N is an assignment statement which assigns an array value. This routine -- expands the assignment into a loop (or nested loops for the case of a -- multi-dimensional array) to do the assignment component by component. - -- Larray and Rarray are the entities of the actual arrays on the left - -- hand and right hand sides. L_Type and R_Type are the types of these - -- arrays (which may not be the same, due to either sliding, or to a - -- change of representation case). Ndim is the number of dimensions and - -- the parameter Rev indicates if the loops run normally (Rev = False), - -- or reversed (Rev = True). The value returned is the constructed - -- loop statement. Auxiliary declarations are inserted before node N - -- using the standard Insert_Actions mechanism. + -- Larray and Rarray are the entities of the actual arrays on the left-hand + -- and right-hand sides. L_Type and R_Type are the types of these arrays + -- (which may not be the same, due to either sliding, or to a change of + -- representation case). Ndim is the number of dimensions and the parameter + -- Rev indicates if the loops run normally (Rev = False), or reversed + -- (Rev = True). The value returned is the constructed loop statement. + -- Auxiliary declarations are inserted before node N using the standard + -- Insert_Actions mechanism. procedure Expand_Assign_Record (N : Node_Id); -- N is an assignment of an untagged record value. This routine handles @@ -359,7 +359,7 @@ package body Exp_Ch5 is begin -- Deal with length check. Note that the length check is done with - -- respect to the right hand side as given, not a possible underlying + -- respect to the right-hand side as given, not a possible underlying -- renamed object, since this would generate incorrect extra checks. Apply_Length_Check (Rhs, L_Type); @@ -420,8 +420,8 @@ package body Exp_Ch5 is end if; -- We certainly must use a loop for change of representation and also - -- we use the operand of the conversion on the right hand side as the - -- effective right hand side (the component types must match in this + -- we use the operand of the conversion on the right-hand side as the + -- effective right-hand side (the component types must match in this -- situation). if Crep then @@ -717,7 +717,7 @@ package body Exp_Ch5 is Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); - -- If both left and right hand arrays are entity names, and refer + -- If both left- and right-hand arrays are entity names, and refer -- to different entities, then we know that the move is safe (the -- two storage areas are completely disjoint). @@ -1004,7 +1004,7 @@ package body Exp_Ch5 is then -- Call TSS procedure for array assignment, passing the - -- explicit bounds of right and left hand sides. + -- explicit bounds of right- and left-hand sides. declare Proc : constant Entity_Id := @@ -1080,7 +1080,7 @@ package body Exp_Ch5 is -- end loop; -- end; - -- Here Rev is False, and Tm1Xn are the subscript types for the right hand + -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand -- side. The declarations of R2b and R4b are inserted before the original -- assignment statement. @@ -1276,7 +1276,7 @@ package body Exp_Ch5 is L_Typ : constant Entity_Id := Base_Type (Etype (Lhs)); begin - -- If change of representation, then extract the real right hand side + -- If change of representation, then extract the real right-hand side -- from the type conversion, and proceed with component-wise assignment, -- since the two types are not the same as far as the back end is -- concerned. @@ -1340,7 +1340,7 @@ package body Exp_Ch5 is -- Given C, the entity for a discriminant or component, build an -- assignment for the corresponding field values. The flag U_U -- signals the presence of an Unchecked_Union and forces the usage - -- of the inferred discriminant value of C as the right hand side + -- of the inferred discriminant value of C as the right-hand side -- of the assignment. function Make_Field_Assigns (CI : List_Id) return List_Id; @@ -1452,7 +1452,7 @@ package body Exp_Ch5 is begin -- In the case of an Unchecked_Union, use the discriminant - -- constraint value as on the right hand side of the assignment. + -- constraint value as on the right-hand side of the assignment. if U_U then Expr := @@ -1617,14 +1617,15 @@ package body Exp_Ch5 is ------------------------------------- procedure Expand_Assign_With_Target_Names (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - LHS : constant Node_Id := Name (N); - RHS : constant Node_Id := Expression (N); - Ent : Entity_Id; + LHS : constant Node_Id := Name (N); + LHS_Typ : constant Entity_Id := Etype (LHS); + Loc : constant Source_Ptr := Sloc (N); + RHS : constant Node_Id := Expression (N); - New_RHS : Node_Id; + Ent : Entity_Id; + -- The entity of the left-hand side - function Replace_Target (N : Node_Id) return Traverse_Result; + function Replace_Target (N : Node_Id) return Traverse_Result; -- Replace occurrences of the target name by the proper entity: either -- the entity of the LHS in simple cases, or the formal of the -- constructed procedure otherwise. @@ -1633,7 +1634,7 @@ package body Exp_Ch5 is -- Replace_Target -- -------------------- - function Replace_Target (N : Node_Id) return Traverse_Result is + function Replace_Target (N : Node_Id) return Traverse_Result is begin if Nkind (N) = N_Target_Name then Rewrite (N, New_Occurrence_Of (Ent, Sloc (N))); @@ -1645,74 +1646,104 @@ package body Exp_Ch5 is procedure Replace_Target_Name is new Traverse_Proc (Replace_Target); - begin + -- Local variables + + New_RHS : Node_Id; + Proc_Id : Entity_Id; + -- Start of processing for Expand_Assign_With_Target_Names + + begin New_RHS := New_Copy_Tree (RHS); + -- The left-hand side is a direct name + if Is_Entity_Name (LHS) - and then not Is_Renaming_Of_Object (Entity (LHS)) + and then not Is_Renaming_Of_Object (Entity (LHS)) then Ent := Entity (LHS); Replace_Target_Name (New_RHS); + + -- Generate: + -- LHS := ... LHS ...; + Rewrite (N, Make_Assignment_Statement (Loc, - Name => Relocate_Node (LHS), + Name => Relocate_Node (LHS), Expression => New_RHS)); + -- The left-hand side is not a direct name, but is side-effect free. + -- Capture its value in a temporary to avoid multiple evaluations. + elsif Side_Effect_Free (LHS) then Ent := Make_Temporary (Loc, 'T'); + Replace_Target_Name (New_RHS); + + -- Generate: + -- T : LHS_Typ := LHS; + Insert_Before_And_Analyze (N, Make_Object_Declaration (Loc, Defining_Identifier => Ent, - Object_Definition => New_Occurrence_Of (Etype (LHS), Loc), + Object_Definition => New_Occurrence_Of (LHS_Typ, Loc), Expression => New_Copy_Tree (LHS))); - Replace_Target_Name (New_RHS); + + -- Generate: + -- LHS := ... T ...; + Rewrite (N, Make_Assignment_Statement (Loc, - Name => Relocate_Node (LHS), + Name => Relocate_Node (LHS), Expression => New_RHS)); + -- Otherwise wrap the whole assignment statement in a procedure with an + -- IN OUT parameter. The original assignment then becomes a call to the + -- procedure with the left-hand side as an actual. + else Ent := Make_Temporary (Loc, 'T'); + Replace_Target_Name (New_RHS); - declare - Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P')); - Formals : constant List_Id := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Ent, - In_Present => True, - Out_Present => True, - Parameter_Type => New_Occurrence_Of (Etype (LHS), Loc))); - Spec : constant Node_Id := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc, - Parameter_Specifications => Formals); - Subp_Body : Node_Id; - Call : Node_Id; - begin - Replace_Target_Name (New_RHS); + -- Generate: + -- procedure P (T : in out LHS_Typ) is + -- begin + -- T := ... T ...; + -- end P; - Subp_Body := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Ent, Loc), - Expression => New_RHS)))); - - Insert_Before_And_Analyze (N, Subp_Body); - Call := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc, Loc), - Parameter_Associations => New_List (Relocate_Node (LHS))); - Rewrite (N, Call); - end; + Proc_Id := Make_Temporary (Loc, 'P'); + + Insert_Before_And_Analyze (N, + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Ent, + In_Present => True, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (LHS_Typ, Loc)))), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => New_RHS))))); + + -- Generate: + -- P (LHS); + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => New_List (Relocate_Node (LHS)))); end if; - -- Analyze rewritten node, either as assignment or procedure call. + -- Analyze rewritten node, either as assignment or procedure call Analyze (N); end Expand_Assign_With_Target_Names; @@ -1762,9 +1793,7 @@ package body Exp_Ch5 is -- Separate expansion if RHS contain target names. Note that assignment -- may already have been expanded if RHS is aggregate. - if Nkind (N) = N_Assignment_Statement - and then Has_Target_Names (N) - then + if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then Expand_Assign_With_Target_Names (N); return; end if; @@ -1922,7 +1951,7 @@ package body Exp_Ch5 is -- where the reference was not expanded in the original tree, -- since it was on the left side of an assignment. But in the -- pre-assignment statement (the object definition), BPAR_Expr - -- will end up on the right hand side, and must be reexpanded. To + -- will end up on the right-hand side, and must be reexpanded. To -- achieve this, we reset the analyzed flag of all selected and -- indexed components down to the actual indexed component for -- the packed array. @@ -2273,7 +2302,7 @@ package body Exp_Ch5 is begin -- In the controlled case, we ensure that function calls are -- evaluated before finalizing the target. In all cases, it makes - -- the expansion easier if the side-effects are removed first. + -- the expansion easier if the side effects are removed first. Remove_Side_Effects (Lhs); Remove_Side_Effects (Rhs); @@ -2599,7 +2628,7 @@ package body Exp_Ch5 is if Validity_Checks_On and then Validity_Check_Copies then - -- Skip this if left hand side is an array or record component + -- Skip this if left-hand side is an array or record component -- and elementary component validity checks are suppressed. if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component) @@ -4810,7 +4839,7 @@ package body Exp_Ch5 is if not Ctrl_Act then null; - -- The left hand side is an uninitialized temporary object + -- The left-hand side is an uninitialized temporary object elsif Nkind (L) = N_Type_Conversion and then Is_Entity_Name (Expression (L)) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 2ae495e0f34..55fcbe6f0d4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8727,7 +8727,7 @@ package body Exp_Ch9 is function Static_Component_Size (Comp : Entity_Id) return Boolean; -- When compiling under the Ravenscar profile, private components must - -- have a static size, or else a protected object will require heap + -- have a static size, or else a protected object will require heap -- allocation, violating the corresponding restriction. It is preferable -- to make this check here, because it provides a better error message -- than the back-end, which refers to the object as a whole. diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index bd898904865..b80ef8294d0 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -33,14 +33,14 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; +with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; +with Stand; use Stand; with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Sem_Eval; use Sem_Eval; -with Stand; use Stand; +with Uintp; use Uintp; package body Exp_SPARK is diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0dd558713e0..4d8e52cee74 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1332,8 +1332,6 @@ package body Freeze is ------------------------------- procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is - Decl : Node_Id; - function Find_Constant (Nod : Node_Id) return Traverse_Result; -- Function to search for deferred constant @@ -1376,6 +1374,10 @@ package body Freeze is procedure Check_Deferred is new Traverse_Proc (Find_Constant); + -- Local variables + + Decl : Node_Id; + -- Start of processing for Check_Expression_Function begin diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index b454af4f52f..776b2284b5d 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -232,6 +232,7 @@ package body Ch4 is -- Loop through designators in qualified name -- AI12-0125 : target_name + if Token = Tok_At_Sign then Scan_Reserved_Identifier (Force_Msg => False); end if; @@ -2331,15 +2332,15 @@ package body Ch4 is -- Come here at end of simple expression, where we do a couple of -- special checks to improve error recovery. - -- Special test to improve error recovery. If the current token - -- is a period, then someone is trying to do selection on something - -- that is not a name, e.g. a qualified expression. + -- Special test to improve error recovery. If the current token is a + -- period, then someone is trying to do selection on something that is + -- not a name, e.g. a qualified expression. if Token = Tok_Dot then Error_Msg_SC ("prefix for selection is not a name"); - -- If qualified expression, comment and continue, otherwise - -- something is pretty nasty so do an Error_Resync call. + -- If qualified expression, comment and continue, otherwise something + -- is pretty nasty so do an Error_Resync call. if Ada_Version < Ada_2012 and then Nkind (Node1) = N_Qualified_Expression @@ -2797,7 +2798,7 @@ package body Ch4 is Error_Msg_SC ("parentheses required for unary minus"); Scan; -- past minus - when Tok_At_Sign => -- AI12-0125 : target_name + when Tok_At_Sign => -- AI12-0125 : target_name if Ada_Version < Ada_2020 then Error_Msg_SC ("target name is an Ada 2020 extension"); Error_Msg_SC ("\compile with -gnatX"); diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 0fae960fe65..ba3c9502b93 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -158,9 +158,9 @@ package body Scng is | Tok_And | Tok_Apostrophe | Tok_Array - | Tok_At_Sign | Tok_Asterisk | Tok_At + | Tok_At_Sign | Tok_Body | Tok_Box | Tok_Char_Literal @@ -1618,6 +1618,7 @@ package body Scng is else -- AI12-0125-03 : @ is target_name + Accumulate_Checksum ('@'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_At_Sign; @@ -2438,6 +2439,7 @@ package body Scng is -- Invalid graphic characters -- Note that '@' is handled elsewhere, because following AI12-125 -- it denotes the target_name of an assignment. + when '#' | '$' | '?' | '`' | '\' | '^' | '~' => -- If Set_Special_Character has been called for this character, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7c6278772b5..db0b1d8c364 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -352,16 +352,16 @@ package body Sem_Ch13 is ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is - Comp : Node_Id; - CC : Node_Id; - Max_Machine_Scalar_Size : constant Uint := UI_From_Int (Standard_Long_Long_Integer_Size); -- We use this as the maximum machine scalar size + SSU : constant Uint := UI_From_Int (System_Storage_Unit); + + CC : Node_Id; + Comp : Node_Id; Num_CC : Natural; - SSU : constant Uint := UI_From_Int (System_Storage_Unit); begin -- Processing here used to depend on Ada version: the behavior was @@ -380,12 +380,12 @@ package body Sem_Ch13 is -- same byte offset and processing them together. Same approach is still -- valid in later versions including Ada 2012. - -- This first loop through components does two things. First it - -- deals with the case of components with component clauses whose - -- length is greater than the maximum machine scalar size (either - -- accepting them or rejecting as needed). Second, it counts the - -- number of components with component clauses whose length does - -- not exceed this maximum for later processing. + -- This first loop through components does two things. First it deals + -- with the case of components with component clauses whose length is + -- greater than the maximum machine scalar size (either accepting them + -- or rejecting as needed). Second, it counts the number of components + -- with component clauses whose length does not exceed this maximum for + -- later processing. Num_CC := 0; Comp := First_Component_Or_Discriminant (R); @@ -402,8 +402,8 @@ package body Sem_Ch13 is if Lbit >= Max_Machine_Scalar_Size then - -- This is allowed only if first bit is zero, and - -- last bit + 1 is a multiple of storage unit size. + -- This is allowed only if first bit is zero, and last bit + -- + 1 is a multiple of storage unit size. if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then @@ -435,28 +435,25 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := Lbit + 1; Error_Msg_Uint_2 := Max_Machine_Scalar_Size; Error_Msg_F - ("\last bit + 1 (^) exceeds maximum machine " - & "scalar size (^)", - First_Bit (CC)); + ("\last bit + 1 (^) exceeds maximum machine scalar " + & "size (^)", First_Bit (CC)); if (Lbit + 1) mod SSU /= 0 then Error_Msg_Uint_1 := SSU; Error_Msg_F ("\and is not a multiple of Storage_Unit (^) " - & "(RM 13.5.1(10))", - First_Bit (CC)); + & "(RM 13.5.1(10))", First_Bit (CC)); else Error_Msg_Uint_1 := Fbit; Error_Msg_F ("\and first bit (^) is non-zero " - & "(RM 13.4.1(10))", - First_Bit (CC)); + & "(RM 13.4.1(10))", First_Bit (CC)); end if; end if; - -- OK case of machine scalar related component clause, - -- For now, just count them. + -- OK case of machine scalar related component clause. For now, + -- just count them. else Num_CC := Num_CC + 1; @@ -467,16 +464,14 @@ package body Sem_Ch13 is Next_Component_Or_Discriminant (Comp); end loop; - -- We need to sort the component clauses on the basis of the - -- Position values in the clause, so we can group clauses with - -- the same Position together to determine the relevant machine - -- scalar size. + -- We need to sort the component clauses on the basis of the Position + -- values in the clause, so we can group clauses with the same Position + -- together to determine the relevant machine scalar size. Sort_CC : declare Comps : array (0 .. Num_CC) of Entity_Id; - -- Array to collect component and discriminant entities. The - -- data starts at index 1, the 0'th entry is for the sort - -- routine. + -- Array to collect component and discriminant entities. The data + -- starts at index 1, the 0'th entry is for the sort routine. function CP_Lt (Op1, Op2 : Natural) return Boolean; -- Compare routine for Sort @@ -486,25 +481,26 @@ package body Sem_Ch13 is package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + MaxL : Uint; + -- Maximum last bit value of any component in this set + + MSS : Uint; + -- Corresponding machine scalar size + Start : Natural; Stop : Natural; -- Start and stop positions in the component list of the set of -- components with the same starting position (that constitute -- components in a single machine scalar). - MaxL : Uint; - -- Maximum last bit value of any component in this set - - MSS : Uint; - -- Corresponding machine scalar size - ----------- -- CP_Lt -- ----------- function CP_Lt (Op1, Op2 : Natural) return Boolean is begin - return Position (Component_Clause (Comps (Op1))) < + return + Position (Component_Clause (Comps (Op1))) < Position (Component_Clause (Comps (Op2))); end CP_Lt; @@ -529,12 +525,12 @@ package body Sem_Ch13 is CC : constant Node_Id := Component_Clause (Comp); begin - -- Collect only component clauses whose last bit is less - -- than machine scalar size. Any component clause whose - -- last bit exceeds this value does not take part in - -- machine scalar layout considerations. The test for - -- Error_Posted makes sure we exclude component clauses - -- for which we already posted an error. + -- Collect only component clauses whose last bit is less than + -- machine scalar size. Any component clause whose last bit + -- exceeds this value does not take part in machine scalar + -- layout considerations. The test for Error_Posted makes sure + -- we exclude component clauses for which we already posted an + -- error. if Present (CC) and then not Error_Posted (Last_Bit (CC)) @@ -553,10 +549,10 @@ package body Sem_Ch13 is Sorting.Sort (Num_CC); - -- We now have all the components whose size does not exceed - -- the max machine scalar value, sorted by starting position. - -- In this loop we gather groups of clauses starting at the - -- same position, to process them in accordance with AI-133. + -- We now have all the components whose size does not exceed the max + -- machine scalar value, sorted by starting position. In this loop we + -- gather groups of clauses starting at the same position, to process + -- them in accordance with AI-133. Stop := 0; while Stop < Num_CC loop @@ -583,14 +579,14 @@ package body Sem_Ch13 is end if; end loop; - -- Now we have a group of component clauses from Start to - -- Stop whose positions are identical, and MaxL is the - -- maximum last bit value of any of these components. + -- Now we have a group of component clauses from Start to Stop + -- whose positions are identical, and MaxL is the maximum last + -- bit value of any of these components. - -- We need to determine the corresponding machine scalar - -- size. This loop assumes that machine scalar sizes are - -- even, and that each possible machine scalar has twice - -- as many bits as the next smaller one. + -- We need to determine the corresponding machine scalar size. + -- This loop assumes that machine scalar sizes are even, and that + -- each possible machine scalar has twice as many bits as the next + -- smaller one. MSS := Max_Machine_Scalar_Size; while MSS mod 2 = 0 @@ -600,10 +596,9 @@ package body Sem_Ch13 is MSS := MSS / 2; end loop; - -- Here is where we fix up the Component_Bit_Offset value - -- to account for the reverse bit order. Some examples of - -- what needs to be done for the case of a machine scalar - -- size of 8 are: + -- Here is where we fix up the Component_Bit_Offset value to + -- account for the reverse bit order. Some examples of what needs + -- to be done for the case of a machine scalar size of 8 are: -- First_Bit .. Last_Bit Component_Bit_Offset -- old new old new @@ -617,8 +612,8 @@ package body Sem_Ch13 is -- 1 .. 4 3 .. 6 1 3 -- 4 .. 7 0 .. 3 4 0 - -- The rule is that the first bit is obtained by subtracting - -- the old ending bit from machine scalar size - 1. + -- The rule is that the first bit is obtained by subtracting the + -- old ending bit from machine scalar size - 1. for C in Start .. Stop loop declare @@ -634,19 +629,19 @@ package body Sem_Ch13 is if Warn_On_Reverse_Bit_Order then Error_Msg_Uint_1 := MSS; Error_Msg_N - ("info: reverse bit order in machine " & - "scalar of length^?V?", First_Bit (CC)); + ("info: reverse bit order in machine scalar of " + & "length^?V?", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE - ("\big-endian range for component " - & "& is ^ .. ^?V?", First_Bit (CC), Comp); + ("\big-endian range for component & is ^ .. ^?V?", + First_Bit (CC), Comp); else Error_Msg_NE - ("\little-endian range for component" - & "& is ^ .. ^?V?", First_Bit (CC), Comp); + ("\little-endian range for component & is ^ .. ^?V?", + First_Bit (CC), Comp); end if; end if; @@ -663,8 +658,8 @@ package body Sem_Ch13 is ------------------------------------------------ procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id) is - Comp : Node_Id; CC : Node_Id; + Comp : Node_Id; begin -- For Ada 95, we just renumber bits within a storage unit. We do the @@ -707,8 +702,8 @@ package body Sem_Ch13 is and then CSZ mod System_Storage_Unit = 0 then Error_Msg_N - ("info: multi-byte field specified with " - & "non-standard Bit_Order?V?", CLC); + ("info: multi-byte field specified with non-standard " + & "Bit_Order?V?", CLC); if Bytes_Big_Endian then Error_Msg_N @@ -724,11 +719,11 @@ package body Sem_Ch13 is else Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); + ("attempt to specify non-contiguous field not " + & "permitted", CLC); Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified in legacy Ada 95 mode", CLC); + ("\caused by non-standard Bit_Order specified in " + & "legacy Ada 95 mode", CLC); end if; -- Case where field fits in one storage unit @@ -740,14 +735,14 @@ package body Sem_Ch13 is and then Warn_On_Reverse_Bit_Order then Error_Msg_N - ("info: Bit_Order clause does not affect " & - "byte ordering?V?", Pos); + ("info: Bit_Order clause does not affect byte " + & "ordering?V?", Pos); Error_Msg_Uint_1 := Intval (Pos) + Intval (FB) / System_Storage_Unit; Error_Msg_N - ("info: position normalized to ^ before bit " & - "order interpreted?V?", Pos); + ("info: position normalized to ^ before bit order " + & "interpreted?V?", Pos); end if; -- Here is where we fix up the Component_Bit_Offset value @@ -769,16 +764,13 @@ package body Sem_Ch13 is -- The rule is that the first bit is is obtained by -- subtracting the old ending bit from storage_unit - 1. - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); + Set_Component_Bit_Offset (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); + Set_Normalized_First_Bit (Comp, + Component_Bit_Offset (Comp) mod System_Storage_Unit); end if; end; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index fb42f6a0717..1f774c00a62 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2634,12 +2634,11 @@ package body Sem_Ch3 is elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then - -- Check for an edge case that may cause premature freezing of a - -- private type. - - -- If there is an type which depends on a private type from an - -- enclosing package that is in the same scope as a non-completing - -- expression function then we cannot freeze here. + -- Check for an edge case that may cause premature freezing of + -- a private type. If there is a type which depends on another + -- private type from an enclosing package that is in the same + -- scope as a non-completing expression function then we cannot + -- freeze here. Ignore_Freezing := False; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 942e21e922e..26d78b6370b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -716,6 +716,23 @@ package body Sem_Ch4 is then null; + -- An unusual case arises when the parent of a derived type is + -- a limited record extension with unknown discriminants, and + -- its full view has no discriminants. + -- + -- A more general fix might be to create the proper underlying + -- type for such a derived type, but it is a record type with + -- no private attributes, so this required extending the + -- meaning of this attribute. ??? + + elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private + and then Present (Underlying_Type (Etype (Type_Id))) + and then + not Has_Discriminants (Underlying_Type (Etype (Type_Id))) + and then not Comes_From_Source (Parent (N)) + then + null; + elsif Is_Class_Wide_Type (Type_Id) then Error_Msg_N ("initialization required in class-wide allocation", N); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6abcdb26d8d..bc7693cb5c4 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -284,7 +284,8 @@ package body Sem_Ch5 is -- Start of processing for Analyze_Assignment begin - -- Save LHS for use in target names (AI12-125). + -- Save LHS for use in target names (AI12-125) + Current_LHS := Lhs; Mark_Coextensions (N, Rhs); @@ -574,9 +575,7 @@ package body Sem_Ch5 is -- the context of the assignment statement. Restore the expander mode -- now so that assignment statement can be properly expanded. - if Nkind (N) = N_Assignment_Statement - and then Has_Target_Names (N) - then + if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then Expander_Mode_Restore; end if; @@ -3543,6 +3542,7 @@ package body Sem_Ch5 is if No (Current_LHS) then Error_Msg_N ("target name can only appear within an assignment", N); Set_Etype (N, Any_Type); + else Set_Has_Target_Names (Parent (Current_LHS)); Set_Etype (N, Etype (Current_LHS)); diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 0f4ac500ca0..99a29510d77 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -41,8 +41,8 @@ package Sem_Ch5 is procedure Analyze_Loop_Parameter_Specification (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Null_Statement (N : Node_Id); - procedure Analyze_Target_Name (N : Node_Id); procedure Analyze_Statements (L : List_Id); + procedure Analyze_Target_Name (N : Node_Id); procedure Analyze_Label_Entity (E : Entity_Id); -- This procedure performs direct analysis of the label entity E. It diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5958d42cbc9..3f714429052 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9140,16 +9140,16 @@ package body Sem_Util is begin -- Protected objects always have the properties Async_Readers and - -- Async_Writers. (SPARK RM 7.1.2(16)) + -- Async_Writers (SPARK RM 7.1.2(16)). if Property = Name_Async_Readers or else Property = Name_Async_Writers then return True; - -- Protected objects that have Part_Of components also inherit - -- their properties Effective_Reads and Effective_Writes. (SPARK - -- RM 7.1.2(16)) + -- Protected objects that have Part_Of components also inherit their + -- properties Effective_Reads and Effective_Writes + -- (SPARK RM 7.1.2(16)). elsif Present (Constits) then Constit_Elmt := First_Elmt (Constits); @@ -9352,8 +9352,9 @@ package body Sem_Util is -- (SPARK RM 7.1.2(16)) if Is_Protected_Type (Etype (Item_Id)) then - return Property = Name_Async_Readers - or else Property = Name_Async_Writers; + return + Property = Name_Async_Readers + or else Property = Name_Async_Writers; else return True; end if; @@ -9377,8 +9378,8 @@ package body Sem_Util is -- By default, protected objects only have the properties Async_Readers -- and Async_Writers. If they have Part_Of components, they also inherit - -- their properties Effective_Reads and Effective_Writes. (SPARK RM - -- 7.1.2(16)) + -- their properties Effective_Reads and Effective_Writes + -- (SPARK RM 7.1.2(16)). elsif Ekind (Item_Id) = E_Protected_Object then return Protected_Object_Has_Enabled_Property; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 56c774500e6..4ff8fb1da9f 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1538,15 +1538,15 @@ package Sinfo is -- A flag present in an N_Task_Definition node to flag the presence of a -- Storage_Size pragma. + -- Has_Target_Names (Flag8-Sem) + -- Present in assignment statements. Indicates that the RHS contains + -- target names (see AI12-0125-3) and must be expanded accordingly. + -- Has_Wide_Character (Flag11-Sem) -- Present in string literals, set if any wide character (i.e. character -- code outside the Character range but within Wide_Character range) -- appears in the string. Used to implement pragma preference rules. - -- Has_Target_Names (Flag8-Sem) - -- Present in assignment statements. Indicates that the RHS contains - -- target names (see AI12-0125-3) and must be expanded accordingly. - -- Has_Wide_Wide_Character (Flag13-Sem) -- Present in string literals, set if any wide character (i.e. character -- code outside the Wide_Character range) appears in the string. Used to -- 2.30.2