diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 33383e7b55e..436f9a55714 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2016-10-12 Hristian Kirtchev + + * exp_ch5.adb, sem_ch3.adb, exp_ch9.adb, a-tags.adb, sem_prag.adb, + sem_ch12.adb, xref_lib.adb, a-strunb-shared.adb, rtsfind.adb, + freeze.adb, sem_attr.adb, sem_case.adb, exp_ch4.adb, ghost.adb, + exp_ch6.adb, sem_ch4.adb, restrict.adb, s-os_lib.adb: Minor + reformatting. + 2016-10-12 Justin Squirek * sem_ch10.adb (Remove_Limited_With_Clause): Add a check to diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index ba308f5cdc4..2199f647b8a 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -625,7 +625,8 @@ package body Ada.Strings.Unbounded is function Can_Be_Reused (Item : not null Shared_String_Access; - Length : Natural) return Boolean is + Length : Natural) return Boolean + is begin return System.Atomic_Counters.Is_One (Item.Counter) diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 07c2139851c..08c4dd91b6b 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -757,10 +757,10 @@ package body Ada.Tags is A_TSD : constant Type_Specific_Data_Ptr := To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); begin - return D_TSD.Access_Level = A_TSD.Access_Level - and then (CW_Membership (Descendant, Ancestor) - or else - IW_Membership (D_TSD, Ancestor)); + return + D_TSD.Access_Level = A_TSD.Access_Level + and then (CW_Membership (Descendant, Ancestor) + or else IW_Membership (D_TSD, Ancestor)); end; end if; end Is_Descendant_At_Same_Level; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 77b70127b50..7931c13ee92 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4280,8 +4280,9 @@ package body Exp_Ch4 is if Nkind (Expression (N)) = N_Qualified_Expression then declare - Exp : constant Node_Id := Expression (Expression (N)); + Exp : constant Node_Id := Expression (Expression (N)); Typ : constant Entity_Id := Etype (Expression (N)); + begin Apply_Constraint_Check (Exp, Typ); Apply_Predicate_Check (Exp, Typ); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 595a559804e..0127bfbf7f6 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -330,10 +330,11 @@ package body Exp_Ch5 is case Nkind (Exp) is when N_Indexed_Component | N_Selected_Component | N_Slice => return Is_Non_Local_Array (Prefix (Exp)); + when others => return - not (Is_Entity_Name (Exp) and then - Scope (Entity (Exp)) = Current_Scope); + not (Is_Entity_Name (Exp) + and then Scope (Entity (Exp)) = Current_Scope); end case; end Is_Non_Local_Array; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a14274c4a98..fa18400c12e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5943,7 +5943,7 @@ package body Exp_Ch6 is Subp : Entity_Id; Scop : Entity_Id) is - Rec : Node_Id; + Rec : Node_Id; procedure Expand_Internal_Init_Call; -- A call to an operation of the type may occur in the initialization @@ -6006,7 +6006,7 @@ package body Exp_Ch6 is -- case this must be handled as an inter-object call. if not In_Open_Scopes (Scop) - or else (not Is_Entity_Name (Name (N))) + or else not Is_Entity_Name (Name (N)) then if Nkind (Name (N)) = N_Selected_Component then Rec := Prefix (Name (N)); @@ -6020,8 +6020,9 @@ package body Exp_Ch6 is -- function of that enclosing type, and this is treated as an -- internal call. - pragma Assert (Is_Entity_Name (Name (N)) - and then Inside_Init_Proc); + pragma Assert + (Is_Entity_Name (Name (N)) and then Inside_Init_Proc); + Expand_Internal_Init_Call; return; end if; @@ -6044,7 +6045,6 @@ package body Exp_Ch6 is Name => Name (N), Rec => Rec, External => False); - end if; -- Analyze and resolve the new call. The actuals have already been diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9467303e2fc..7109dcdf82b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1106,8 +1106,8 @@ package body Exp_Ch9 is procedure Build_Class_Wide_Master (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); - Master_Id : Entity_Id; Master_Decl : Node_Id; + Master_Id : Entity_Id; Master_Scope : Entity_Id; Name_Id : Node_Id; Related_Node : Node_Id; @@ -8390,21 +8390,25 @@ package body Exp_Ch9 is procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Proc : Entity_Id; + begin + -- Try to use System.Relative_Delays.Delay_For only if available. This + -- is the implementation used on restricted platforms when Ada.Calendar + -- is not available. + if RTE_Available (RO_RD_Delay_For) then - -- Try to use System.Relative_Delays.Delay_For only if available. - -- This is the implementation used on restricted platforms when - -- Ada.Calendar is not available. Proc := RTE (RO_RD_Delay_For); + + -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error + -- message if not available. + else - -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error - -- message if not available. Proc := RTE (RO_CA_Delay_For); end if; Rewrite (N, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc, Loc), + Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => New_List (Expression (N)))); Analyze (N); end Expand_N_Delay_Relative_Statement; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d5e8540c0c6..b28be4fcecb 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1408,7 +1408,7 @@ package body Freeze is -- care of all overridings and is done only once. if Present (Overridden_Operation (Prim)) - and then Comes_From_Source (Prim) + and then Comes_From_Source (Prim) then Update_Primitives_Mapping (Overridden_Operation (Prim), Prim); @@ -1444,9 +1444,7 @@ package body Freeze is Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop Prim := Node (Op_Node); - if not Comes_From_Source (Prim) - and then Present (Alias (Prim)) - then + if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); A_Pre := Find_Aspect (Par_Prim, Aspect_Pre); diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 60b3866a905..8621aea1514 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -617,9 +617,9 @@ package body Ghost is -- A non-Ghost primitive of a type extension cannot override an -- inherited Ghost primitive (SPARK RM 6.9(8)). - if not Is_Ghost_Entity (Subp) + if Is_Ghost_Entity (Over_Subp) + and then not Is_Ghost_Entity (Subp) and then not Is_Abstract_Subprogram (Subp) - and then Is_Ghost_Entity (Over_Subp) then Error_Msg_N ("incompatible overriding in effect", Subp); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 9d22f854e89..a66fffb5ee9 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -1195,17 +1195,17 @@ package body Restrict is declare R : Restriction_Flags renames - Profile_Info (Restricted_Tasking).Set; + Profile_Info (Restricted_Tasking).Set; V : Restriction_Values renames - Profile_Info (Restricted_Tasking).Value; + Profile_Info (Restricted_Tasking).Value; begin for J in R'Range loop if R (J) and then (Restrictions.Set (J) = False - or else Restriction_Warnings (J) - or else - (J in All_Parameter_Restrictions - and then Restrictions.Value (J) > V (J))) + or else Restriction_Warnings (J) + or else + (J in All_Parameter_Restrictions + and then Restrictions.Value (J) > V (J))) then Restricted_Profile_Result := False; exit; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 5745b00cfd8..6e94ccbd942 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -1169,15 +1169,19 @@ package body Rtsfind is M (P + 1) := '.'; P := P + 1; - -- Add entity name and closing quote to message + -- Strip "RE" if RE_Image (2) = 'E' then - -- Strip "RE" S := 4; + + -- Strip "RO_XX" + else - -- Strip "RO_XX" S := 7; end if; + + -- Add entity name and closing quote to message + Name_Len := RE_Image'Length - S + 1; Name_Buffer (1 .. Name_Len) := RE_Image (S .. RE_Image'Last); Set_Casing (Mixed_Case); diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 5da95112340..5ac823e6cde 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -511,7 +511,6 @@ package body System.OS_Lib is when None => null; end case; - end Copy_To; -- Start of processing for Copy_File @@ -622,6 +621,7 @@ package body System.OS_Lib is Ada_Pathname : String_Access := To_Path_String_Access (Pathname, C_String_Length (Pathname)); + begin Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); Free (Ada_Name); @@ -639,9 +639,10 @@ package body System.OS_Lib is Copy_Timestamp : Boolean := True; Copy_Permissions : Boolean := True) is - F : aliased String (1 .. From'Length + 1); + F : aliased String (1 .. From'Length + 1); + T : aliased String (1 .. To'Length + 1); + Mode : Integer; - T : aliased String (1 .. To'Length + 1); begin if Copy_Timestamp then @@ -713,6 +714,7 @@ package body System.OS_Lib is Ada_Dest : String_Access := To_Path_String_Access (Dest, C_String_Length (Dest)); + begin Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); Free (Ada_Source); @@ -1504,6 +1506,7 @@ package body System.OS_Lib is pragma Import (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file"); F_Name : String (1 .. Name'Length + 1); + begin F_Name (1 .. Name'Length) := Name; F_Name (F_Name'Last) := ASCII.NUL; @@ -1595,6 +1598,7 @@ package body System.OS_Lib is pragma Import (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file"); F_Name : String (1 .. Name'Length + 1); + begin F_Name (1 .. Name'Length) := Name; F_Name (F_Name'Last) := ASCII.NUL; @@ -1849,8 +1853,8 @@ package body System.OS_Lib is else Result := - Non_Blocking_Spawn - (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); -- Close the file just created for the output, as the file descriptor -- cannot be used anywhere, being a local value. It is safe to do @@ -2628,6 +2632,7 @@ package body System.OS_Lib is function rename (From, To : Address) return Integer; pragma Import (C, rename, "__gnat_rename"); R : Integer; + begin R := rename (Old_Name, New_Name); Success := (R = 0); @@ -2640,6 +2645,7 @@ package body System.OS_Lib is is C_Old_Name : String (1 .. Old_Name'Length + 1); C_New_Name : String (1 .. New_Name'Length + 1); + begin C_Old_Name (1 .. Old_Name'Length) := Old_Name; C_Old_Name (C_Old_Name'Last) := ASCII.NUL; @@ -2673,6 +2679,7 @@ package body System.OS_Lib is procedure C_Set_Executable (Name : C_File_Name; Mode : Integer); pragma Import (C, C_Set_Executable, "__gnat_set_executable"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2687,6 +2694,7 @@ package body System.OS_Lib is procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time); pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2701,6 +2709,7 @@ package body System.OS_Lib is procedure C_Set_Non_Readable (Name : C_File_Name); pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2715,6 +2724,7 @@ package body System.OS_Lib is procedure C_Set_Non_Writable (Name : C_File_Name); pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2729,6 +2739,7 @@ package body System.OS_Lib is procedure C_Set_Readable (Name : C_File_Name); pragma Import (C, C_Set_Readable, "__gnat_set_readable"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2743,6 +2754,7 @@ package body System.OS_Lib is procedure C_Set_Writable (Name : C_File_Name); pragma Import (C, C_Set_Writable, "__gnat_set_writable"); C_Name : aliased String (Name'First .. Name'Last + 1); + begin C_Name (Name'Range) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -2889,8 +2901,8 @@ package body System.OS_Lib is type Chars is array (Positive range <>) of aliased Character; type Char_Ptr is access constant Character; - Command_Len : constant Positive := Program_Name'Length + 1 + - Args_Length (Args); + Command_Len : constant Positive := + Program_Name'Length + 1 + Args_Length (Args); Command_Last : Natural := 0; Command : aliased Chars (1 .. Command_Len); -- Command contains all characters of the Program_Name and Args, all diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 4e00e17a762..b457aa45114 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -68,7 +68,6 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; with System; -with System.CRC32; use System.CRC32; with Stringt; use Stringt; with Style; with Stylesw; use Stylesw; @@ -79,6 +78,8 @@ with Uintp; use Uintp; with Uname; use Uname; with Urealp; use Urealp; +with System.CRC32; use System.CRC32; + package body Sem_Attr is True_Value : constant Uint := Uint_1; @@ -5288,7 +5289,8 @@ package body Sem_Attr is -- Local variables In_Inlined_C_Postcondition : constant Boolean := - Modify_Tree_For_C and then In_Inlined_Body; + Modify_Tree_For_C + and then In_Inlined_Body; Legal : Boolean; Pref_Id : Entity_Id; @@ -5339,7 +5341,7 @@ package body Sem_Attr is if Chars (Spec_Id) = Name_uPostconditions or else (In_Inlined_C_Postcondition - and then Nkind (Parent (Spec_Id)) = N_Block_Statement) + and then Nkind (Parent (Spec_Id)) = N_Block_Statement) then Rewrite (N, Make_Identifier (Loc, Name_uResult)); @@ -6136,149 +6138,150 @@ package body Sem_Attr is -- Type_Key -- -------------- - when Attribute_Type_Key => + when Attribute_Type_Key => Type_Key : declare + Full_Name : constant String_Id := + Fully_Qualified_Name_String (Entity (P)); + + CRC : CRC32; + -- The computed signature for the type + + Deref : Boolean; + -- To simplify the handling of mutually recursive types, follow a + -- single dereference link in a composite type. + + procedure Compute_Type_Key (T : Entity_Id); + -- Create a CRC integer from the declaration of the type, For a + -- composite type, fold in the representation of its components in + -- recursive fashion. We use directly the source representation of + -- the types involved. + + ---------------------- + -- Compute_Type_Key -- + ---------------------- + + procedure Compute_Type_Key (T : Entity_Id) is + Buffer : Source_Buffer_Ptr; + P_Max : Source_Ptr; + P_Min : Source_Ptr; + Rep : Node_Id; + SFI : Source_File_Index; + + procedure Process_One_Declaration; + -- Update CRC with the characters of one type declaration, or a + -- representation pragma that applies to the type. + + ----------------------------- + -- Process_One_Declaration -- + ----------------------------- + + procedure Process_One_Declaration is + Ptr : Source_Ptr; + + begin + Ptr := P_Min; + + -- Scan type declaration, skipping blanks + + while Ptr <= P_Max loop + if Buffer (Ptr) /= ' ' then + System.CRC32.Update (CRC, Buffer (Ptr)); + end if; + + Ptr := Ptr + 1; + end loop; + end Process_One_Declaration; + + -- Start of processing for Compute_Type_Key + + begin + if Is_Itype (T) then + return; + end if; + + Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max); + SFI := Get_Source_File_Index (P_Min); + Buffer := Source_Text (SFI); + + Process_One_Declaration; + + -- Recurse on relevant component types + + if Is_Array_Type (T) then + Compute_Type_Key (Component_Type (T)); + + elsif Is_Access_Type (T) then + if not Deref then + Deref := True; + Compute_Type_Key (Designated_Type (T)); + end if; + + elsif Is_Derived_Type (T) then + Compute_Type_Key (Etype (T)); + + elsif Is_Record_Type (T) then + declare + Comp : Entity_Id; + begin + Comp := First_Component (T); + while Present (Comp) loop + Compute_Type_Key (Etype (Comp)); + Next_Component (Comp); + end loop; + end; + end if; + + -- Fold in representation aspects for the type, which appear in + -- the same source buffer. + + Rep := First_Rep_Item (T); + + while Present (Rep) loop + if Comes_From_Source (Rep) then + Sloc_Range (Rep, P_Min, P_Max); + Process_One_Declaration; + end if; + + Rep := Next_Rep_Item (Rep); + end loop; + end Compute_Type_Key; + + -- Start of processing for Type_Key + + begin Check_E0; Check_Type; - declare - Full_Name : constant String_Id := - Fully_Qualified_Name_String (Entity (P)); + Start_String; + Deref := False; - Deref : Boolean; - -- To simplify the handling of mutually recursive types, follow - -- a single dereference link in a composite type. + -- Copy all characters in Full_Name but the trailing NUL - CRC : CRC32; - -- The computed signature for the type. + for J in 1 .. String_Length (Full_Name) - 1 loop + Store_String_Char (Get_String_Char (Full_Name, Pos (J))); + end loop; - procedure Compute_Type_Key (T : Entity_Id); - -- Create a CRC integer from the declaration of the type, For - -- a composite type, fold in the representation of its components - -- in recursive fashion. We use directly the source representation - -- of the types involved. + -- For standard type return the name of the type. as there is no + -- explicit source declaration to use. Otherwise compute CRC and + -- convert it to string one character at a time so as not to use + -- Image within the compiler. - -------------- - -- Type_Key -- - -------------- + if Scope (Entity (P)) /= Standard_Standard then + Initialize (CRC); + Compute_Type_Key (Entity (P)); - procedure Compute_Type_Key (T : Entity_Id) is - SFI : Source_File_Index; - Buffer : Source_Buffer_Ptr; - P_Min, P_Max : Source_Ptr; - Rep : Node_Id; - - procedure Process_One_Declaration; - -- Update CRC with the characters of one type declaration, - -- or a representation pragma that applies to the type. - - ----------------------------- - -- Process_One_Declaration -- - ----------------------------- - - procedure Process_One_Declaration is - Ptr : Source_Ptr; - - begin - Ptr := P_Min; - - -- Scan type declaration, skipping blanks, - - while Ptr <= P_Max loop - if Buffer (Ptr) /= ' ' then - System.CRC32.Update (CRC, Buffer (Ptr)); - end if; - - Ptr := Ptr + 1; - end loop; - end Process_One_Declaration; - - begin -- Start of processing for Compute_Type_Key - - if Is_Itype (T) then - return; - end if; - - Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max); - SFI := Get_Source_File_Index (P_Min); - Buffer := Source_Text (SFI); - - Process_One_Declaration; - - -- Recurse on relevant component types. - - if Is_Array_Type (T) then - Compute_Type_Key (Component_Type (T)); - - elsif Is_Access_Type (T) then - if not Deref then - Deref := True; - Compute_Type_Key (Designated_Type (T)); - end if; - - elsif Is_Derived_Type (T) then - Compute_Type_Key (Etype (T)); - - elsif Is_Record_Type (T) then - declare - Comp : Entity_Id; - begin - Comp := First_Component (T); - while Present (Comp) loop - Compute_Type_Key (Etype (Comp)); - - Next_Component (Comp); - end loop; - end; - end if; - - -- Fold in representation aspects for the type, which - -- appear in the same source buffer. - - Rep := First_Rep_Item (T); - - while Present (Rep) loop - if Comes_From_Source (Rep) then - Sloc_Range (Rep, P_Min, P_Max); - Process_One_Declaration; - end if; - - Rep := Next_Rep_Item (Rep); - end loop; - end Compute_Type_Key; - - begin - Start_String; - Deref := False; - - -- Copy all characters in Full_Name but the trailing NUL - - for J in 1 .. String_Length (Full_Name) - 1 loop - Store_String_Char (Get_String_Char (Full_Name, Pos (J))); - end loop; - - -- For standard type return the name of the type. as there is - -- no explicit source declaration to use. Otherwise compute - -- CRC and convert it to string one character at a time. so as - -- not to use Image within the compiler. - - if Scope (Entity (P)) /= Standard_Standard then - Initialize (CRC); - Compute_Type_Key (Entity (P)); - - if not Is_Frozen (Entity (P)) then - Error_Msg_N ("premature usage of Type_Key?", N); - end if; - - while CRC > 0 loop - Store_String_Char (Character'Val (48 + (CRC rem 10))); - CRC := CRC / 10; - end loop; + if not Is_Frozen (Entity (P)) then + Error_Msg_N ("premature usage of Type_Key?", N); end if; - Rewrite (N, Make_String_Literal (Loc, End_String)); - end; + while CRC > 0 loop + Store_String_Char (Character'Val (48 + (CRC rem 10))); + CRC := CRC / 10; + end loop; + end if; + Rewrite (N, Make_String_Literal (Loc, End_String)); Analyze_And_Resolve (N, Standard_String); + end Type_Key; ----------------------- -- Unbiased_Rounding -- diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 7415b0c89d5..039a44485c4 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -455,51 +455,48 @@ package body Sem_Case is ---------------------- procedure Check_Duplicates is - Prev_Hi : Uint := Expr_Value (Choice_Table (1).Hi); + Choice : Node_Id; + Choice_Hi : Uint; + Choice_Lo : Uint; + Prev_Choice : Node_Id; + Prev_Hi : Uint; + begin + Prev_Hi := Expr_Value (Choice_Table (1).Hi); + for Outer_Index in 2 .. Num_Choices loop - declare - Choice_Lo : constant Uint := - Expr_Value (Choice_Table (Outer_Index).Lo); - Choice_Hi : constant Uint := - Expr_Value (Choice_Table (Outer_Index).Hi); - begin - if Choice_Lo <= Prev_Hi then - -- Choices overlap; this is an error + Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); + Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); - declare - Choice : constant Node_Id := - Choice_Table (Outer_Index).Node; - Prev_Choice : Node_Id; - begin - -- Find first previous choice that overlaps + -- Choices overlap; this is an error - for Inner_Index in 1 .. Outer_Index - 1 loop - if Choice_Lo <= - Expr_Value (Choice_Table (Inner_Index).Hi) - then - Prev_Choice := Choice_Table (Inner_Index).Node; - exit; - end if; - end loop; + if Choice_Lo <= Prev_Hi then + Choice := Choice_Table (Outer_Index).Node; - if Sloc (Prev_Choice) <= Sloc (Choice) then - Error_Msg_Sloc := Sloc (Prev_Choice); - Dup_Choice - (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); - else - Error_Msg_Sloc := Sloc (Choice); - Dup_Choice - (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), - Prev_Choice); - end if; - end; + -- Find first previous choice that overlaps + + for Inner_Index in 1 .. Outer_Index - 1 loop + if Choice_Lo <= + Expr_Value (Choice_Table (Inner_Index).Hi) + then + Prev_Choice := Choice_Table (Inner_Index).Node; + exit; + end if; + end loop; + + if Sloc (Prev_Choice) <= Sloc (Choice) then + Error_Msg_Sloc := Sloc (Prev_Choice); + Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); + else + Error_Msg_Sloc := Sloc (Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); end if; + end if; - if Choice_Hi > Prev_Hi then - Prev_Hi := Choice_Hi; - end if; - end; + if Choice_Hi > Prev_Hi then + Prev_Hi := Choice_Hi; + end if; end loop; end Check_Duplicates; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ed5e948377f..b0a9ff66cac 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8948,7 +8948,6 @@ package body Sem_Ch12 is Gen_Body : Node_Id; Gen_Decl : Node_Id) is - function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean; -- Check if the generic definition and the instantiation come from -- a common scope, in which case the instance must be frozen after @@ -8990,12 +8989,12 @@ package body Sem_Ch12 is --------------- function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is - Res : Source_Ptr; N1 : Node_Id; + Res : Source_Ptr; begin Res := Sloc (N); - N1 := N; + N1 := N; while Present (N1) and then N1 /= Act_Unit loop if Sloc (N1) > Res then Res := Sloc (N1); @@ -9013,11 +9012,11 @@ package body Sem_Ch12 is Par : constant Entity_Id := Scope (Gen_Id); Gen_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (Gen_Decl))); - Orig_Body : Node_Id := Gen_Body; - F_Node : Node_Id; - Body_Unit : Node_Id; + Body_Unit : Node_Id; + F_Node : Node_Id; Must_Delay : Boolean; + Orig_Body : Node_Id := Gen_Body; -- Start of processing for Install_Body @@ -9080,13 +9079,13 @@ package body Sem_Ch12 is Must_Delay := (Gen_Unit = Act_Unit - and then (Nkind_In (Gen_Unit, N_Package_Declaration, - N_Generic_Package_Declaration) + and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, + N_Package_Declaration) or else (Gen_Unit = Body_Unit and then True_Sloc (N, Act_Unit) < Sloc (Orig_Body))) and then Is_In_Main_Unit (Original_Node (Gen_Unit)) - and then (In_Same_Scope (Gen_Id, Act_Id))); + and then In_Same_Scope (Gen_Id, Act_Id)); -- If this is an early instantiation, the freeze node is placed after -- the generic body. Otherwise, if the generic appears in an instance, @@ -12914,7 +12913,6 @@ package body Sem_Ch12 is end if; Current_Unit := Parent (N); - while Present (Current_Unit) and then Nkind (Current_Unit) /= N_Compilation_Unit loop diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2bd90717435..3b9435f92f7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -877,6 +877,7 @@ package body Sem_Ch3 is then Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); end if; + return Anon_Type; end if; @@ -14758,9 +14759,9 @@ package body Sem_Ch3 is or else Is_Private_Overriding or else Is_Internal_Name (Chars (Parent_Subp)) or else (Is_Controlled (Parent_Type) - and then Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize)) + and then Nam_In (Chars (Parent_Subp), Name_Adjust, + Name_Finalize, + Name_Initialize)) then Set_Derived_Name; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5c0f4f66c0c..888d6e9edd5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4804,6 +4804,7 @@ package body Sem_Ch4 is In_Scope := In_Open_Scopes (Prefix_Type); while Present (Comp) loop + -- Do not examine private operations of the type if not within -- its scope. @@ -4821,10 +4822,9 @@ package body Sem_Ch4 is -- a visible entity is found. if Is_Tagged_Type (Prefix_Type) - and then - Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call, - N_Indexed_Component) + and then Nkind_In (Parent (N), N_Function_Call, + N_Indexed_Component, + N_Procedure_Call_Statement) and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9128294556f..d95cab895b6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -26411,9 +26411,6 @@ package body Sem_Prag is Par_Subp : Entity_Id; Adjust_Sloc : Boolean) is - Par_Formal : Entity_Id; - Subp_Formal : Entity_Id; - function Replace_Entity (N : Node_Id) return Traverse_Result; -- Replace reference to formal of inherited operation or to primitive -- operation of root type, with corresponding entity for derived type, @@ -26516,6 +26513,11 @@ package body Sem_Prag is procedure Replace_Condition_Entities is new Traverse_Proc (Replace_Entity); + -- Local variables + + Par_Formal : Entity_Id; + Subp_Formal : Entity_Id; + -- Start of processing for Build_Class_Wide_Expression begin diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index c43c575354e..92508414a03 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -645,7 +645,7 @@ package body Xref_Lib is declare Table : Table_Type renames - File.Dep.Table (1 .. Last (File.Dep)); + File.Dep.Table (1 .. Last (File.Dep)); begin Table (Num_Dependencies) := Add_To_Xref_File (Ali (File_Start .. File_End),