From f5afb270e6dae6d56ddad1fb2b8661dffe03259c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 15:43:04 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Yannick Moy * sem_res.adb (Resolve_Logical_Op): ensure N is a binary operator before accessing operands. * sem_util.adb (Is_SPARK_Initialization_Expr): follow original nodes to decide whether an initialization expression respects SPARK rules, as the plain node is the expanded one. This allows for more valid warnings to be issued. * gnat_rm.texi: Minor update. 2011-08-02 Arnaud Charlet * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Revert previous change. 2011-08-02 Robert Dewar * sem_ch3.adb, sem_ch4.adb: Minor reformatting. 2011-08-02 Hristian Kirtchev * exp_ch5.adb (Expand_Iterator_Loop): Reformatting. Wrap the original loop statements and the element renaming declaration with a block when the element type is controlled. 2011-08-02 Yannick Moy * sinfo.ads: Minor formatting. 2011-08-02 Ed Schonberg * sem_aggr.adb (Add_Association): if the association has a box and no expression, use the Sloc of the aggregate itself for the new association. * errout.adb (First_Node): Exclude nodes with no Sloc, and always use the Original_Node. From-SVN: r177153 --- gcc/ada/ChangeLog | 37 +++++++++++++++++++++ gcc/ada/errout.adb | 11 ++++--- gcc/ada/exp_ch5.adb | 76 +++++++++++++++++++++++++++++++------------- gcc/ada/gnat_rm.texi | 5 ++- gcc/ada/sem_aggr.adb | 51 +++++++++++++++++++++++++++-- gcc/ada/sem_ch13.adb | 2 +- gcc/ada/sem_ch3.adb | 4 ++- gcc/ada/sem_ch4.adb | 7 ++-- gcc/ada/sem_res.adb | 33 +++++++++---------- gcc/ada/sem_util.adb | 37 ++++++++++----------- gcc/ada/sinfo.ads | 20 ++++++------ 11 files changed, 206 insertions(+), 77 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 854196c6398..0308954eed8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2011-08-02 Yannick Moy + + * sem_res.adb (Resolve_Logical_Op): ensure N is a binary operator + before accessing operands. + * sem_util.adb (Is_SPARK_Initialization_Expr): follow original nodes to + decide whether an initialization expression respects SPARK rules, as + the plain node is the expanded one. This allows for more valid warnings + to be issued. + * gnat_rm.texi: Minor update. + +2011-08-02 Arnaud Charlet + + * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Revert + previous change. + +2011-08-02 Robert Dewar + + * sem_ch3.adb, sem_ch4.adb: Minor reformatting. + +2011-08-02 Hristian Kirtchev + + * exp_ch5.adb (Expand_Iterator_Loop): Reformatting. Wrap the original + loop statements and the element renaming declaration with a block when + the element type is controlled. + +2011-08-02 Yannick Moy + + * sinfo.ads: Minor formatting. + +2011-08-02 Ed Schonberg + + * sem_aggr.adb (Add_Association): if the association has a box and no + expression, use the Sloc of the aggregate itself for the new + association. + * errout.adb (First_Node): Exclude nodes with no Sloc, and always use + the Original_Node. + 2011-08-02 Hristian Kirtchev * exp_ch5.adb (Expand_Iterator_Loop): Code cleanup and refactoring. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 06878e8ebb1..076fec223df 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1308,6 +1308,7 @@ package body Errout is function First_Node (C : Node_Id) return Node_Id is L : constant Source_Ptr := Sloc (Original_Node (C)); + Orig : constant Node_Id := Original_Node (C); Sfile : constant Source_File_Index := Get_Source_File_Index (L); Earliest : Node_Id; Eloc : Source_Ptr; @@ -1333,6 +1334,7 @@ package body Errout is if Loc < Eloc and then Loc /= Standard_Location + and then Loc /= No_Location and then Get_Source_File_Index (Loc) = Sfile then Earliest := Original_Node (N); @@ -1345,13 +1347,14 @@ package body Errout is -- Start of processing for First_Node begin - if Nkind (C) in N_Subexpr then - Earliest := Original_Node (C); + if Nkind (Orig) in N_Subexpr then + Earliest := Orig; Eloc := Sloc (Earliest); - Search_Tree_First (Original_Node (C)); + Search_Tree_First (Orig); return Earliest; + else - return C; + return Orig; end if; end First_Node; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a7b73cda222..7ff1a3dcce2 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2770,13 +2770,12 @@ package body Exp_Ch5 is I_Spec : constant Node_Id := Iterator_Specification (Isc); Id : constant Entity_Id := Defining_Identifier (I_Spec); Loc : constant Source_Ptr := Sloc (N); - Stats : constant List_Id := Statements (N); Container : constant Node_Id := Name (I_Spec); Container_Typ : constant Entity_Id := Etype (Container); - - Cursor : Entity_Id; - New_Loop : Node_Id; + Cursor : Entity_Id; + New_Loop : Node_Id; + Stats : List_Id := Statements (N); begin -- Processing for arrays @@ -2839,25 +2838,32 @@ package body Exp_Ch5 is -- Processing for containers else - -- In both cases these require a cursor of the proper type + -- The for loop is expanded into a while loop which uses a container + -- specific cursor to examine each element. -- Cursor : Pack.Cursor := Container.First; -- while Cursor /= Pack.No_Element loop - -- Obj : Pack.Element_Type renames Element (Cursor); - -- -- for the "of" form + -- declare + -- -- the block is added when Element_Type is controlled - -- + -- Obj : Pack.Element_Type := Element (Cursor); + -- -- for the "of" loop form + -- begin + -- + -- end; -- Pack.Next (Cursor); -- end loop; - -- with the obvious replacements if "reverse" is specified. Pack is - -- the name of the package which instantiates the container. + -- If "reverse" is present, then the initialization of the cursor + -- uses Last and the step becomes Prev. Pack is the name of the + -- package which instantiates the container. declare Element_Type : constant Entity_Id := Etype (Id); Pack : constant Entity_Id := Scope (Base_Type (Container_Typ)); + Decl : Node_Id; Cntr : Node_Id; Name_Init : Name_Id; Name_Step : Name_Id; @@ -2873,26 +2879,52 @@ package body Exp_Ch5 is -- The code below only handles containers where Element is not a -- primitive operation of the container. This excludes for now the - -- Hi-Lite formal containers. Generate: - -- - -- Id : Element_Type renames Container.Element (Cursor); + -- Hi-Lite formal containers. if Of_Present (I_Spec) then - Prepend_To (Stats, + + -- Generate: + -- Id : Element_Type := Pack.Element (Cursor); + + Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, Subtype_Mark => - New_Occurrence_Of (Element_Type, Loc), + New_Reference_To (Element_Type, Loc), Name => Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of (Pack, Loc), + New_Reference_To (Pack, Loc), Selector_Name => Make_Identifier (Loc, Chars => Name_Element)), Expressions => New_List ( - New_Occurrence_Of (Cursor, Loc))))); + New_Reference_To (Cursor, Loc)))); + + -- When the container holds controlled objects, wrap the loop + -- statements and element renaming declaration with a block. + -- This ensures that the transient result of Element (Cursor) + -- is cleaned up after each iteration of the loop. + + if Needs_Finalization (Element_Type) then + + -- Generate: + -- declare + -- Id : Element_Type := Pack.Element (Cursor); + -- begin + -- + -- end; + + Stats := New_List ( + Make_Block_Statement (Loc, + Declarations => New_List (Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + else + Prepend_To (Stats, Decl); + end if; end if; -- Determine the advancement and initialization steps for the @@ -2918,12 +2950,12 @@ package body Exp_Ch5 is Name => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of (Pack, Loc), + New_Reference_To (Pack, Loc), Selector_Name => Make_Identifier (Loc, Name_Step)), Parameter_Associations => New_List ( - New_Occurrence_Of (Cursor, Loc)))); + New_Reference_To (Cursor, Loc)))); -- Generate: -- while Cursor /= Pack.No_Element loop @@ -2937,11 +2969,11 @@ package body Exp_Ch5 is Condition => Make_Op_Ne (Loc, Left_Opnd => - New_Occurrence_Of (Cursor, Loc), + New_Reference_To (Cursor, Loc), Right_Opnd => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of (Pack, Loc), + New_Reference_To (Pack, Loc), Selector_Name => Make_Identifier (Loc, Name_No_Element)))), Statements => Stats, @@ -2985,7 +3017,7 @@ package body Exp_Ch5 is Object_Definition => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of (Pack, Loc), + New_Reference_To (Pack, Loc), Selector_Name => Make_Identifier (Loc, Name_Cursor)), diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index ce6745750c8..ac0a7ee6d19 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -9059,7 +9059,10 @@ the Ada mode for the unit, so a unit compiled in Ada 95 mode with SPARK restrictions will be checked for constructs forbidden in SPARK 95. Error messages related to SPARK restriction have the form: -@code{(spark) error message}. +@smallexample +violation of restriction "Spark" at + +@end smallexample This is not a replacement for the semantic checks performed by the SPARK Examiner tool, as the compiler only deals currently with code, diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 421d04c9f20..89db3d005df 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1171,6 +1171,17 @@ package body Sem_Aggr is end if; if not Aggr_Resolved then + + -- A parenthesized expression may have been intended as an + -- aggregate, leading to a type error when analyzing the + -- component. This can also happen for a nested component + -- (see Analyze_Aggr_Expr). + + if Paren_Count (N) > 0 then + Error_Msg_N + ("positional aggregate cannot have one component", N); + end if; + Aggr_Subtyp := Any_Composite; else Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); @@ -1589,6 +1600,7 @@ package body Sem_Aggr is ("\if single-component aggregate is intended," & " write e.g. (1 ='> ...)", Expr); end if; + return Failure; end if; end if; @@ -1742,6 +1754,31 @@ package body Sem_Aggr is return Failure; end if; + if Others_Present + and then Nkind (Parent (N)) /= N_Component_Association + and then No (Expressions (N)) + and then + Nkind (First (Choices (First (Component_Associations (N))))) + = N_Others_Choice + and then Is_Elementary_Type (Component_Typ) + and then False + then + declare + Assoc : constant Node_Id := First (Component_Associations (N)); + begin + Rewrite (Assoc, + Make_Component_Association (Loc, + Choices => + New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Typ, Loc), + Attribute_Name => Name_Range)), + Expression => Relocate_Node (Expression (Assoc)))); + return Resolve_Array_Aggregate + (N, Index, Index_Constr, Component_Typ, Others_Allowed); + end; + end if; + -- Protect against cascaded errors if Etype (Index_Typ) = Any_Type then @@ -2752,13 +2789,23 @@ package body Sem_Aggr is Assoc_List : List_Id; Is_Box_Present : Boolean := False) is + Loc : Source_Ptr; Choice_List : constant List_Id := New_List; New_Assoc : Node_Id; begin - Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List); + -- If this is a box association the expression is missing, so + -- use the Sloc of the aggregate itself for the new association. + + if Present (Expr) then + Loc := Sloc (Expr); + else + Loc := Sloc (N); + end if; + + Append (New_Occurrence_Of (Component, Loc), Choice_List); New_Assoc := - Make_Component_Association (Sloc (Expr), + Make_Component_Association (Loc, Choices => Choice_List, Expression => Expr, Box_Present => Is_Box_Present); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 901b9e033dc..a1af56f5aec 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2843,7 +2843,7 @@ package body Sem_Ch13 is -- Pointer to node for literal providing max value begin - if Ignore_Rep_Clauses or else CodePeer_Mode then + if Ignore_Rep_Clauses then return; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1884d03cb10..0571ab24eb8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3175,7 +3175,9 @@ package body Sem_Ch3 is if Nkind (Original_Node (N)) = N_Object_Declaration and then Comes_From_Source (Original_Node (N)) - -- only call test if needed + + -- Only call test if needed + and then (Formal_Verification_Mode or else Restriction_Check_Required (SPARK)) and then not Is_SPARK_Initialization_Expr (E) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index f0b5dd600b0..5a5169bc50d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -809,9 +809,11 @@ package body Sem_Ch4 is procedure Check_Mixed_Parameter_And_Named_Associations is Actual : Node_Id; Named_Seen : Boolean; + begin - Actual := First (Actuals); Named_Seen := False; + + Actual := First (Actuals); while Present (Actual) loop case Nkind (Actual) is when N_Parameter_Association => @@ -1922,7 +1924,8 @@ package body Sem_Ch4 is --------------------------- procedure Process_Function_Call is - Actual : Node_Id; + Actual : Node_Id; + begin Change_Node (N, N_Function_Call); Set_Name (N, P); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3f778c3a809..4d54142b5b8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7324,22 +7324,23 @@ package body Sem_Res is -- bounds. Of course the types have to match, so only check if operands -- are compatible and the node itself has no errors. - declare - Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); - Right_Typ : constant Node_Id := Etype (Right_Opnd (N)); - begin - if Is_Array_Type (B_Typ) - and then Nkind (N) in N_Binary_Op - and then Base_Type (Left_Typ) = Base_Type (Right_Typ) - and then Left_Typ /= Any_Composite -- or else Left_Opnd in error - and then Right_Typ /= Any_Composite -- or else Right_Opnd in error - and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) - then - Check_Formal_Restriction - ("array types should have matching static bounds", N); - end if; - end; - + if Is_Array_Type (B_Typ) + and then Nkind (N) in N_Binary_Op + then + declare + Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); + Right_Typ : constant Node_Id := Etype (Right_Opnd (N)); + begin + if Base_Type (Left_Typ) = Base_Type (Right_Typ) + and then Left_Typ /= Any_Composite -- or Left_Opnd in error + and then Right_Typ /= Any_Composite -- or Right_Opnd in error + and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) + then + Check_Formal_Restriction + ("array types should have matching static bounds", N); + end if; + end; + end if; end Resolve_Logical_Op; --------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5239f5dd104..dbe5887690b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7503,17 +7503,18 @@ package body Sem_Util is Is_Ok : Boolean; Expr : Node_Id; Comp_Assn : Node_Id; + Orig_N : constant Node_Id := Original_Node (N); begin Is_Ok := True; - if not Comes_From_Source (N) then + if not Comes_From_Source (Orig_N) then goto Done; end if; - pragma Assert (Nkind (N) in N_Subexpr); + pragma Assert (Nkind (Orig_N) in N_Subexpr); - case Nkind (N) is + case Nkind (Orig_N) is when N_Character_Literal | N_Integer_Literal | N_Real_Literal | @@ -7522,17 +7523,17 @@ package body Sem_Util is when N_Identifier | N_Expanded_Name => - if Is_Entity_Name (N) - and then Present (Entity (N)) -- needed in some cases + if Is_Entity_Name (Orig_N) + and then Present (Entity (Orig_N)) -- needed in some cases then - case Ekind (Entity (N)) is + case Ekind (Entity (Orig_N)) is when E_Constant | E_Enumeration_Literal | E_Named_Integer | E_Named_Real => null; when others => - if Is_Type (Entity (N)) then + if Is_Type (Entity (Orig_N)) then null; else Is_Ok := False; @@ -7542,24 +7543,24 @@ package body Sem_Util is when N_Qualified_Expression | N_Type_Conversion => - Is_Ok := Is_SPARK_Initialization_Expr (Expression (N)); + Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N)); when N_Unary_Op => - Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (N)); + Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); when N_Binary_Op | N_Short_Circuit | N_Membership_Test => - Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (N)) - and then Is_SPARK_Initialization_Expr (Right_Opnd (N)); + Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N)) + and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); when N_Aggregate | N_Extension_Aggregate => - if Nkind (N) = N_Extension_Aggregate then - Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (N)); + if Nkind (Orig_N) = N_Extension_Aggregate then + Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N)); end if; - Expr := First (Expressions (N)); + Expr := First (Expressions (Orig_N)); while Present (Expr) loop if not Is_SPARK_Initialization_Expr (Expr) then Is_Ok := False; @@ -7569,7 +7570,7 @@ package body Sem_Util is Next (Expr); end loop; - Comp_Assn := First (Component_Associations (N)); + Comp_Assn := First (Component_Associations (Orig_N)); while Present (Comp_Assn) loop Expr := Expression (Comp_Assn); if Present (Expr) -- needed for box association @@ -7583,11 +7584,11 @@ package body Sem_Util is end loop; when N_Attribute_Reference => - if Nkind (Prefix (N)) in N_Subexpr then - Is_Ok := Is_SPARK_Initialization_Expr (Prefix (N)); + if Nkind (Prefix (Orig_N)) in N_Subexpr then + Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N)); end if; - Expr := First (Expressions (N)); + Expr := First (Expressions (Orig_N)); while Present (Expr) loop if not Is_SPARK_Initialization_Expr (Expr) then Is_Ok := False; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index cdf71bc51ca..e5ca5aae247 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2095,7 +2095,7 @@ package Sinfo is -- pragma has a local name argument (such as pragma Inline), it is -- resolved to point to the specific entity affected by the pragma. - -------------------------------------- + -------------------------------------- -- 2.8 Pragma Argument Association -- -------------------------------------- @@ -4203,9 +4203,9 @@ package Sinfo is -- True. So after semantic analysis, the Identifier is always set, -- referencing an identifier whose entity has an Ekind of E_Loop. - -------------------------- - -- 5.5 Iteration Scheme -- - -------------------------- + --------------------------- + -- 5.5 Iteration Scheme -- + --------------------------- -- ITERATION_SCHEME ::= -- while CONDITION @@ -4228,7 +4228,7 @@ package Sinfo is -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case) --------------------------------------- - -- 5.5 Loop parameter specification -- + -- 5.5 Loop Parameter Specification -- --------------------------------------- -- LOOP_PARAMETER_SPECIFICATION ::= @@ -4240,9 +4240,9 @@ package Sinfo is -- Reverse_Present (Flag15) -- Discrete_Subtype_Definition (Node4) - ---------------------------------- - -- 5.5.1 Iterator specification -- - ---------------------------------- + ----------------------------------- + -- 5.5.1 Iterator Specification -- + ----------------------------------- -- ITERATOR_SPECIFICATION ::= -- DEFINING_IDENTIFIER in [reverse] NAME @@ -4512,14 +4512,14 @@ package Sinfo is -- profile. Instead the information appears directly in the parent. ---------------------- - -- 6.1 Formal part -- + -- 6.1 Formal Part -- ---------------------- -- FORMAL_PART ::= -- (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) ---------------------------------- - -- 6.1 Parameter specification -- + -- 6.1 Parameter Specification -- ---------------------------------- -- PARAMETER_SPECIFICATION ::= -- 2.30.2