From: Arnaud Charlet Date: Mon, 23 Jan 2017 13:24:47 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9313a26a9ad02e45a1b75d9274f5025015356669;p=gcc.git [multiple changes] 2017-01-23 Gary Dismukes * exp_strm.ads: Minor reformatting and typo fixes. 2017-01-23 Hristian Kirtchev * sem_aggr.adb, par_sco.adb, exp_util.adb, sem.adb, sem_ch4.adb, exp_aggr.adb: Minor reformatting. * g-diopit.adb: minor grammar/punctuation fix in comment. * g-byorma.ads: minor fix of unbalanced parens in comment. 2017-01-23 Hristian Kirtchev * par.adb: Update the documentation of component Labl. * par-ch6.adb (P_Return_Statement): Set the expected label of an extended return statement to Error. 2017-01-23 Tristan Gingold * s-boustr.ads, s-boustr.adb (Is_Full): New function. 2017-01-23 Ed Schonberg * expander.adb: Handle N_Delta_Aggregate. 2017-01-23 Javier Miranda * exp_ch6.adb (Expand_Call): Improve the code that checks if some formal of the called subprogram is a class-wide interface, to handle subtypes of class-wide interfaces. 2017-01-23 Javier Miranda * checks.adb (Apply_Parameter_Aliasing_Checks): Remove side effects of the actuals before generating the overlap check. From-SVN: r244806 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 431885486a0..2ab1f234c55 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2017-01-23 Gary Dismukes + + * exp_strm.ads: Minor reformatting and typo fixes. + +2017-01-23 Hristian Kirtchev + + * sem_aggr.adb, par_sco.adb, exp_util.adb, sem.adb, sem_ch4.adb, + exp_aggr.adb: Minor reformatting. + * g-diopit.adb: minor grammar/punctuation fix in comment. + * g-byorma.ads: minor fix of unbalanced parens in comment. + +2017-01-23 Hristian Kirtchev + + * par.adb: Update the documentation of component Labl. + * par-ch6.adb (P_Return_Statement): Set the expected label of + an extended return statement to Error. + +2017-01-23 Tristan Gingold + + * s-boustr.ads, s-boustr.adb (Is_Full): New function. + +2017-01-23 Ed Schonberg + + * expander.adb: Handle N_Delta_Aggregate. + +2017-01-23 Javier Miranda + + * exp_ch6.adb (Expand_Call): Improve the code that + checks if some formal of the called subprogram is a class-wide + interface, to handle subtypes of class-wide interfaces. + +2017-01-23 Javier Miranda + + * checks.adb (Apply_Parameter_Aliasing_Checks): + Remove side effects of the actuals before generating the overlap + check. + 2017-01-23 Justin Squirek * exp_strm.ads, exp_strm.ads diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 011878eb046..f0ba9a8ad9e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2360,6 +2360,9 @@ package body Checks is and then not Is_Elementary_Type (Etype (Orig_Act_2)) and then May_Cause_Aliasing (Formal_1, Formal_2) then + Remove_Side_Effects (Actual_1); + Remove_Side_Effects (Actual_2); + Overlap_Check (Actual_1 => Actual_1, Actual_2 => Actual_2, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a41bfa08aed..6a0b0d53244 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6444,16 +6444,16 @@ package body Exp_Aggr is ------------------------------ procedure Expand_N_Delta_Aggregate (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Temp : constant Entity_Id := Make_Temporary (Loc, 'T'); - Typ : constant Entity_Id := Etype (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); Decl : Node_Id; begin - Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => New_Copy_Tree (Expression (N))); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => New_Copy_Tree (Expression (N))); if Is_Array_Type (Etype (N)) then Expand_Delta_Array_Aggregate (N, New_List (Decl)); @@ -6467,15 +6467,19 @@ package body Exp_Aggr is ---------------------------------- procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is - Loc : constant Source_Ptr := Sloc (N); - Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); - Assoc : Node_Id; - Choice : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Defining_Identifier (First (Deltas)); + Assoc : Node_Id; + function Generate_Loop (C : Node_Id) return Node_Id; -- Generate a loop containing individual component assignments for -- choices that are ranges, subtype indications, subtype names, and -- iterated component associations. + ------------------- + -- Generate_Loop -- + ------------------- + function Generate_Loop (C : Node_Id) return Node_Id is Sl : constant Source_Ptr := Sloc (C); Ix : Entity_Id; @@ -6491,21 +6495,29 @@ package body Exp_Aggr is return Make_Loop_Statement (Loc, - Iteration_Scheme => Make_Iteration_Scheme (Sl, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Sl, - Defining_Identifier => Ix, - Discrete_Subtype_Definition => New_Copy_Tree (C))), - End_Label => Empty, - Statements => - New_List ( - Make_Assignment_Statement (Sl, - Name => Make_Indexed_Component (Sl, + Iteration_Scheme => + Make_Iteration_Scheme (Sl, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Sl, + Defining_Identifier => Ix, + Discrete_Subtype_Definition => New_Copy_Tree (C))), + + Statements => New_List ( + Make_Assignment_Statement (Sl, + Name => + Make_Indexed_Component (Sl, Prefix => New_Occurrence_Of (Temp, Sl), Expressions => New_List (New_Occurrence_Of (Ix, Sl))), - Expression => New_Copy_Tree (Expression (Assoc))))); + Expression => New_Copy_Tree (Expression (Assoc)))), + End_Label => Empty); end Generate_Loop; + -- Local variables + + Choice : Node_Id; + + -- Start of processing for Expand_Delta_Array_Aggregate + begin Assoc := First (Component_Associations (N)); while Present (Assoc) loop @@ -6524,7 +6536,7 @@ package body Exp_Aggr is if Nkind (Choice) = N_Range or else (Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice))) + and then Is_Type (Entity (Choice))) then Append_To (Deltas, Generate_Loop (Choice)); @@ -6534,11 +6546,12 @@ package body Exp_Aggr is else Append_To (Deltas, - Make_Assignment_Statement (Sloc (Choice), - Name => Make_Indexed_Component (Sloc (Choice), - Prefix => New_Occurrence_Of (Temp, Loc), - Expressions => New_List (New_Copy_Tree (Choice))), - Expression => New_Copy_Tree (Expression (Assoc)))); + Make_Assignment_Statement (Sloc (Choice), + Name => + Make_Indexed_Component (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Expressions => New_List (New_Copy_Tree (Choice))), + Expression => New_Copy_Tree (Expression (Assoc)))); end if; Next (Choice); @@ -6569,11 +6582,12 @@ package body Exp_Aggr is Choice := First (Choice_List (Assoc)); while Present (Choice) loop Append_To (Deltas, - Make_Assignment_Statement (Sloc (Choice), - Name => Make_Selected_Component (Sloc (Choice), - Prefix => New_Occurrence_Of (Temp, Loc), - Selector_Name => Make_Identifier (Loc, Chars (Choice))), - Expression => New_Copy_Tree (Expression (Assoc)))); + Make_Assignment_Statement (Sloc (Choice), + Name => + Make_Selected_Component (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Selector_Name => Make_Identifier (Loc, Chars (Choice))), + Expression => New_Copy_Tree (Expression (Assoc)))); Next (Choice); end loop; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a6579c28e39..e9f13319ed5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2832,10 +2832,12 @@ package body Exp_Ch6 is CW_Interface_Formals_Present := CW_Interface_Formals_Present or else - (Ekind (Etype (Formal)) = E_Class_Wide_Type + (Is_Class_Wide_Type (Etype (Formal)) and then Is_Interface (Etype (Etype (Formal)))) or else (Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Class_Wide_Type (Directly_Designated_Type + (Etype (Etype (Formal)))) and then Is_Interface (Directly_Designated_Type (Etype (Etype (Formal))))); diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads index 397206c93fb..e3b859f1564 100644 --- a/gcc/ada/exp_strm.ads +++ b/gcc/ada/exp_strm.ads @@ -111,10 +111,10 @@ package Exp_Strm is Fnam : out Entity_Id; Use_Underlying : Boolean := True); -- Build function for Input attribute for record type or for an elementary - -- type (the latter is used only in the case where a user defined Read - -- routine is defined, since in other cases, Input calls the appropriate - -- runtime library routine directly. The flag Use_Underlying controls - -- weither the base type or the underlying type of the base type of Typ is + -- type (the latter is used only in the case where a user-defined Read + -- routine is defined, since, in other cases, Input calls the appropriate + -- runtime library routine directly). The flag Use_Underlying controls + -- whether the base type or the underlying type of the base type of Typ is -- used during construction. procedure Build_Record_Or_Elementary_Output_Procedure diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3a1d98587c7..67a6c64a1d4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3783,8 +3783,8 @@ package body Exp_Util is -- Nothing to be done if no underlying record view available -- If this is a limited type derived from a type with unknown - -- discriminants, do not expand either, so that subsequent - -- expansion of the call can add build-in-place parameters to call. + -- discriminants, do not expand either, so that subsequent expansion + -- of the call can add build-in-place parameters to call. if No (Underlying_Record_View (Unc_Type)) or else Is_Limited_Type (Unc_Type) diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 9045b6a72b7..23dd9197156 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -215,6 +215,9 @@ package body Expander is when N_Delay_Until_Statement => Expand_N_Delay_Until_Statement (N); + when N_Delta_Aggregate => + Expand_N_Delta_Aggregate (N); + when N_Entry_Body => Expand_N_Entry_Body (N); diff --git a/gcc/ada/g-byorma.ads b/gcc/ada/g-byorma.ads index 46db6e475ea..a58006e6dcc 100644 --- a/gcc/ada/g-byorma.ads +++ b/gcc/ada/g-byorma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2013, AdaCore -- +-- Copyright (C) 2006-2016, AdaCore -- -- -- -- 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- -- @@ -32,7 +32,7 @@ -- This package provides a procedure for reading and interpreting the BOM -- (byte order mark) used to publish the encoding method for a string (for -- example, a UTF-8 encoded file in windows will start with the appropriate --- BOM sequence to signal UTF-8 encoding. +-- BOM sequence to signal UTF-8 encoding). -- There are two cases diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb index dabea22616f..65bd65c0229 100644 --- a/gcc/ada/g-diopit.adb +++ b/gcc/ada/g-diopit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2015, AdaCore -- +-- Copyright (C) 2001-2016, AdaCore -- -- -- -- 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- -- @@ -140,9 +140,9 @@ package body GNAT.Directory_Operations.Iteration is (Directory : String; File_Pattern : String; Suffix_Pattern : String); - -- Read entries in Directory and call user's callback if the entry - -- match File_Pattern and Suffix_Pattern is empty otherwise it will go - -- down one more directory level by calling Next_Level routine above. + -- Read entries in Directory and call user's callback if the entry match + -- File_Pattern and Suffix_Pattern is empty; otherwise go down one more + -- directory level by calling Next_Level routine below. procedure Next_Level (Current_Path : String; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 4dda2980c80..5c846645e9d 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1898,6 +1898,11 @@ package body Ch3 is ("aspect specifications must come after initialization " & "expression", Sloc (First (Aspect_Specifications (Decl_Node)))); + + else + -- In any case, the assignment symbol doesn't belong. + + Error_Msg ("misplaced assignment symbol", Scan_Ptr); end if; Set_Expression (Decl_Node, Init_Expr_Opt); diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 73a0066c0a1..a1733d99bf1 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -1909,8 +1909,9 @@ package body Ch6 is if Token = Tok_Do then Push_Scope_Stack; - Scope.Table (Scope.Last).Etyp := E_Return; Scope.Table (Scope.Last).Ecol := Ret_Strt; + Scope.Table (Scope.Last).Etyp := E_Return; + Scope.Table (Scope.Last).Labl := Error; Scope.Table (Scope.Last).Sloc := Ret_Sloc; Scan; -- past DO diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 9b5c9c532a8..d3c069a04a9 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -476,8 +476,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- subprogram specifications and bodies the field holds the correponding -- program unit name. For task declarations and bodies, protected types -- and bodies, and accept statements the field hold the name of the type - -- or operation. For if-statements, case-statements, and selects, the - -- field is initialized to Error. + -- or operation. For if-statements, case-statements, return statements, + -- and selects, the field is initialized to Error. -- Note: this is a bit of an odd (mis)use of Error, since there is no -- Error, but we use this value as a place holder to indicate that it diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index ceed72c8c10..3747605a29e 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -1431,9 +1431,9 @@ package body Par_SCO is -- Record first entries used in SC/SD at this recursive level procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); - -- Extend the current statement sequence to encompass the node N. Typ - -- is the letter that identifies the type of statement/declaration that - -- is being added to the sequence. + -- Extend the current statement sequence to encompass the node N. Typ is + -- the letter that identifies the type of statement/declaration that is + -- being added to the sequence. procedure Process_Decisions_Defer (N : Node_Id; T : Character); pragma Inline (Process_Decisions_Defer); @@ -1461,8 +1461,8 @@ package body Par_SCO is -- Helper for Traverse_One: traverse N's aspect specifications procedure Traverse_Degenerate_Subprogram (N : Node_Id); - -- Common code to handle null procedures and expression functions. - -- Emit a SCO of the given Kind and N outside of the dominance flow. + -- Common code to handle null procedures and expression functions. Emit + -- a SCO of the given Kind and N outside of the dominance flow. ------------------------------- -- Extend_Statement_Sequence -- @@ -1745,9 +1745,9 @@ package body Par_SCO is -- Save last statement in current sequence as dominant begin - -- Output statement SCO for degenerate subprogram body - -- (null statement or freestanding expression) outside of - -- the dominance chain. + -- Output statement SCO for degenerate subprogram body (null + -- statement or freestanding expression) outside of the dominance + -- chain. Current_Dominant := No_Dominant; Extend_Statement_Sequence (N, Typ => ' '); @@ -1758,11 +1758,12 @@ package body Par_SCO is if Nkind (N) in N_Subexpr then Process_Decisions_Defer (N, 'X'); end if; + Set_Statement_Entry; - -- Restore current dominant information designating last - -- statement in previous sequence (i.e. make the dominance - -- chain skip over the degenerate body). + -- Restore current dominant information designating last statement + -- in previous sequence (i.e. make the dominance chain skip over + -- the degenerate body). Current_Dominant := Saved_Dominant; end; @@ -1801,9 +1802,9 @@ package body Par_SCO is -- Subprogram declaration or subprogram body stub - when N_Subprogram_Body_Stub + when N_Expression_Function + | N_Subprogram_Body_Stub | N_Subprogram_Declaration - | N_Expression_Function => declare Spec : constant Node_Id := Specification (N); @@ -1819,9 +1820,9 @@ package body Par_SCO is then Traverse_Degenerate_Subprogram (N); - -- Case of an expression function: generate a statement - -- SCO for the expression (and then decision SCOs for any - -- nested decisions). + -- Case of an expression function: generate a statement SCO + -- for the expression (and then decision SCOs for any nested + -- decisions). elsif Nkind (N) = N_Expression_Function then Traverse_Degenerate_Subprogram (Expression (N)); diff --git a/gcc/ada/s-boustr.adb b/gcc/ada/s-boustr.adb index ca07dbb0932..1eb168d95a8 100644 --- a/gcc/ada/s-boustr.adb +++ b/gcc/ada/s-boustr.adb @@ -83,6 +83,15 @@ package body System.Bounded_Strings is Append (X, S (P - 1 .. S'Last)); end Append_Address; + ------------- + -- Is_Full -- + ------------- + + function Is_Full (X : Bounded_String) return Boolean is + begin + return X.Length >= X.Max_Length; + end Is_Full; + --------------- -- To_String -- --------------- diff --git a/gcc/ada/s-boustr.ads b/gcc/ada/s-boustr.ads index 6e81a49506c..0cc2ccec8b4 100644 --- a/gcc/ada/s-boustr.ads +++ b/gcc/ada/s-boustr.ads @@ -48,6 +48,9 @@ package System.Bounded_Strings is procedure Append_Address (X : in out Bounded_String; A : Address); -- Append an address to X + function Is_Full (X : Bounded_String) return Boolean; + -- Return True iff X is full and any character or string will be dropped + -- if appended. private type Bounded_String (Max_Length : Natural) is limited record Length : Natural := 0; diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 2bcf56e500d..ee1809e2ec1 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2016, 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- -- @@ -270,6 +270,7 @@ package System.OS_Interface is pragma Import (C, getpid, "getpid"); PR_SET_NAME : constant := 15; + PR_GET_NAME : constant := 16; function prctl (option : int; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 85990f6dfb6..ad603d8e58d 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -755,14 +755,55 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := pthread_self; Self_ID.Common.LL.LWP := lwp_self; - if Self_ID.Common.Task_Image_Len > 0 then + -- Set thread name to ease debugging. If the name of the task is + -- "foreign thread" (as set by Register_Foreign_Thread) retrieve + -- the name of the thread and update the name of the task instead. + + if Self_ID.Common.Task_Image_Len = 14 + and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread" + then + declare + Thread_Name : String (1 .. 16); + -- PR_GET_NAME returns a string of up to 16 bytes + + Len : Natural := 0; + -- Length of the task name contained in Task_Name + + Result : int; + -- Result from the prctl call + begin + Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address)); + pragma Assert (Result = 0); + + -- Find the length of the given name + + for J in Thread_Name'Range loop + if Thread_Name (J) /= ASCII.NUL then + Len := Len + 1; + else + exit; + end if; + end loop; + + -- Cover the odd situtation if someone decides to change + -- Parameters.Max_Task_Image_Length to less than 16 characters + + if Len > Parameters.Max_Task_Image_Length then + Len := Parameters.Max_Task_Image_Length; + end if; + + -- Copy the name of the thread to the task's ATCB + + Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len); + Self_ID.Common.Task_Image_Len := Len; + end; + + elsif Self_ID.Common.Task_Image_Len > 0 then declare Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1); Result : int; begin - -- Set thread name to ease debugging - Task_Name (1 .. Self_ID.Common.Task_Image_Len) := Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len); Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index bae89ad5ad1..9b7c4903974 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -196,12 +196,12 @@ package body Sem is when N_Delay_Relative_Statement => Analyze_Delay_Relative (N); - when N_Delta_Aggregate => - Analyze_Aggregate (N); - when N_Delay_Until_Statement => Analyze_Delay_Until (N); + when N_Delta_Aggregate => + Analyze_Aggregate (N); + when N_Entry_Body => Analyze_Entry_Body (N); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 65d586da32a..efa5d60b6af 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2740,12 +2740,8 @@ package body Sem_Aggr is ----------------------------- procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is - Base : constant Node_Id := Expression (N); - Deltas : constant List_Id := Component_Associations (N); - Assoc : Node_Id; - Choice : Node_Id; - Comp_Type : Entity_Id; - Index_Type : Entity_Id; + Base : constant Node_Id := Expression (N); + Deltas : constant List_Id := Component_Associations (N); function Get_Component_Type (Nam : Node_Id) return Entity_Id; @@ -2775,12 +2771,22 @@ package body Sem_Aggr is return Any_Type; end Get_Component_Type; + -- Local variables + + Assoc : Node_Id; + Choice : Node_Id; + Comp_Type : Entity_Id; + Index_Type : Entity_Id; + + -- Start of processing for Resolve_Delta_Aggregate + begin if not Is_Composite_Type (Typ) then Error_Msg_N ("not a composite type", N); end if; Analyze_And_Resolve (Base, Typ); + if Is_Array_Type (Typ) then Index_Type := Etype (First_Index (Typ)); Assoc := First (Deltas); @@ -2800,10 +2806,10 @@ package body Sem_Aggr is end loop; declare - Id : constant Entity_Id := Defining_Identifier (Assoc); - Ent : constant Entity_Id := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Assoc), 'L'); + Id : constant Entity_Id := Defining_Identifier (Assoc); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Assoc), 'L'); begin Set_Etype (Ent, Standard_Void_Type); @@ -2838,8 +2844,9 @@ package body Sem_Aggr is if Base_Type (Entity (Choice)) /= Base_Type (Index_Type) then - Error_Msg_NE ("choice does mat match index type of", - Choice, Typ); + Error_Msg_NE + ("choice does mat match index type of", + Choice, Typ); end if; else Resolve (Choice, Index_Type); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7a2666144b9..ef4206b9b30 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -9287,19 +9287,20 @@ package body Sem_Ch4 is Typ := Corresponding_Record_Type (Typ); end if; - -- Simple case. Object may be a subtype of the tagged type or - -- may be the corresponding record of a synchronized type. + -- Simple case. Object may be a subtype of the tagged type or may + -- be the corresponding record of a synchronized type. return Obj_Type = Typ or else Base_Type (Obj_Type) = Typ or else Corr_Type = Typ -- Object may be of a derived type whose parent has unknown - -- discriminants, in which case the type matches the - -- underlying record view of its base. + -- discriminants, in which case the type matches the underlying + -- record view of its base. - or else (Has_Unknown_Discriminants (Typ) - and then Typ = Underlying_Record_View (Base_Type (Obj_Type))) + or else + (Has_Unknown_Discriminants (Typ) + and then Typ = Underlying_Record_View (Base_Type (Obj_Type))) -- Prefix can be dereferenced @@ -9307,8 +9308,8 @@ package body Sem_Ch4 is (Is_Access_Type (Corr_Type) and then Designated_Type (Corr_Type) = Typ) - -- Formal is an access parameter, for which the object - -- can provide an access. + -- Formal is an access parameter, for which the object can + -- provide an access. or else (Ekind (Typ) = E_Anonymous_Access_Type