From a5fe697b1ef0b00f41d7a1d5a8101dc4f8fece26 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 11:21:47 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Yannick Moy * sem_aggr.adb (Check_Qualified_Aggregate): new procedure which checks qualification of aggregates in formal mode (Is_Top_Level_Aggregate): returns True for an aggregate not contained in another aggregate (Resolve_Aggregate): complete the test that an aggregate is adequately qualified in formal mode 2011-08-02 Pascal Obry * make.adb, bindgen.adb, gnatbind.adb: Minor reformatting. * mlib-prj.adb: Supress warning when compiling binder generated file. (Build_Library): Supress all warnings when compiling the binder generated file. From-SVN: r177103 --- gcc/ada/ChangeLog | 16 ++++++ gcc/ada/Makefile.rtl | 4 +- gcc/ada/a-cfdlli.adb | 4 ++ gcc/ada/a-cfhama.adb | 4 ++ gcc/ada/a-cfhase.adb | 4 ++ gcc/ada/a-cforma.adb | 4 ++ gcc/ada/a-cforse.adb | 4 ++ gcc/ada/a-cofove.adb | 4 ++ gcc/ada/bindgen.adb | 7 ++- gcc/ada/gnatbind.adb | 9 +-- gcc/ada/make.adb | 47 ++++++++-------- gcc/ada/mlib-prj.adb | 8 ++- gcc/ada/sem_aggr.adb | 131 +++++++++++++++++++++++++++++-------------- 13 files changed, 166 insertions(+), 80 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b50d02af143..2eae3c872d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2011-08-02 Yannick Moy + + * sem_aggr.adb (Check_Qualified_Aggregate): new procedure which checks + qualification of aggregates in formal mode + (Is_Top_Level_Aggregate): returns True for an aggregate not contained in + another aggregate + (Resolve_Aggregate): complete the test that an aggregate is adequately + qualified in formal mode + +2011-08-02 Pascal Obry + + * make.adb, bindgen.adb, gnatbind.adb: Minor reformatting. + * mlib-prj.adb: Supress warning when compiling binder generated file. + (Build_Library): Supress all warnings when compiling the binder + generated file. + 2011-08-02 Yannick Moy * errout.adb, errout.ads (Check_Formal_Restriction): move procedure diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 3617bea7b77..ed7ec12c150 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -92,11 +92,11 @@ GNATRTL_NONTASKING_OBJS= \ a-cbdlli$(objext) \ a-cborma$(objext) \ a-cdlili$(objext) \ + a-cfdlli$(objext) \ a-cfhama$(objext) \ a-cfhase$(objext) \ - a-cforse$(objext) \ - a-cfdlli$(objext) \ a-cforma$(objext) \ + a-cforse$(objext) \ a-cgaaso$(objext) \ a-cgarso$(objext) \ a-cgcaso$(objext) \ diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 4f70f8174f6..ed34d0e3f27 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 34a8a43f1fc..bc83c9d140a 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index ed514c826d6..0df686d303a 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index 705fd618e9f..f4519173095 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 30a0f97a31d..229af23996b 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index fd30ca9cda7..a0fddf97ffc 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -8,6 +8,10 @@ -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index b17d7b9a1af..5d1928df2c0 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1442,7 +1442,6 @@ package body Bindgen is end if; end; end loop; - end Gen_Elab_Calls_C; ---------------------- @@ -3030,6 +3029,10 @@ package body Bindgen is procedure Increment_Ubuf; -- Little procedure to increment the serial number + -------------------- + -- Increment_Ubuf -- + -------------------- + procedure Increment_Ubuf is begin for J in reverse Ubuf'Range loop @@ -3081,7 +3084,6 @@ package body Bindgen is Write_Statement_Buffer; end if; end loop; - end Gen_Versions_Ada; -------------------- @@ -3129,7 +3131,6 @@ package body Bindgen is Write_Statement_Buffer; end if; end loop; - end Gen_Versions_C; ------------------------ diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index de3084f0267..2c83bf2262d 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -469,12 +469,11 @@ procedure Gnatbind is end Scan_Bind_Arg; procedure Check_Version_And_Help is - new Check_Version_And_Help_G (Bindusg.Display); + new Check_Version_And_Help_G (Bindusg.Display); -- Start of processing for Gnatbind begin - -- Set default for Shared_Libgnat option declare @@ -876,9 +875,8 @@ begin -- Put_In_Sources -- -------------------- - function Put_In_Sources (S : File_Name_Type) - return Boolean - is + function Put_In_Sources + (S : File_Name_Type) return Boolean is begin for J in 1 .. Closure_Sources.Last loop if Closure_Sources.Table (J) = S then @@ -978,5 +976,4 @@ begin null; end if; - end Gnatbind; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 5bf466633fc..5fe7c7454c3 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2213,7 +2213,6 @@ package body Make is Check_File (Name_Find); end if; end loop; - end Check_Linker_Options; ----------------- @@ -6066,21 +6065,19 @@ package body Make is end loop; for Index in 1 .. Library_Projs.Last loop - if Library_Projs.Table - (Index).Library_Kind = Static + if Library_Projs.Table (Index).Library_Kind = Static and then not Targparm.OpenVMS_On_Target then Linker_Switches.Increment_Last; Linker_Switches.Table (Linker_Switches.Last) := new String' (Get_Name_String - (Library_Projs.Table (Index). - Library_Dir.Display_Name) & + (Library_Projs.Table + (Index).Library_Dir.Display_Name) & Directory_Separator & "lib" & Get_Name_String - (Library_Projs.Table (Index). - Library_Name) & + (Library_Projs.Table (Index). Library_Name) & "." & MLib.Tgt.Archive_Ext); @@ -6109,7 +6106,7 @@ package body Make is if Libraries_Present then -- If Path_Option is not null, create the switch - -- ("-Wl,-rpath," or equivalent) with all the non static + -- ("-Wl,-rpath," or equivalent) with all the non-static -- library dirs plus the standard GNAT library dir. -- We do that only if Run_Path_Option is True -- (not disabled by -R switch). @@ -6134,17 +6131,19 @@ package body Make is loop Linker_Switches.Increment_Last; Linker_Switches.Table - (Linker_Switches.Last) := new String' - (Path_Option.all & - Library_Paths.Table (Index).all); + (Linker_Switches.Last) := + new String' + (Path_Option.all & + Library_Paths.Table (Index).all); end loop; -- One switch for the standard GNAT library dir Linker_Switches.Increment_Last; Linker_Switches.Table - (Linker_Switches.Last) := new String' - (Path_Option.all & MLib.Utl.Lib_Directory); + (Linker_Switches.Last) := + new String' + (Path_Option.all & MLib.Utl.Lib_Directory); else -- We are going to create one switch of the form @@ -6178,8 +6177,8 @@ package body Make is loop Option (Current + 1 .. - Current + - Library_Paths.Table (Index)'Length) := + Current + + Library_Paths.Table (Index)'Length) := Library_Paths.Table (Index).all; Current := Current + @@ -6351,19 +6350,19 @@ package body Make is not Unique_Compile); The_Packages : constant Package_Id := - Main_Project.Decl.Packages; + Main_Project.Decl.Packages; Binder_Package : constant Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Binder, - In_Packages => The_Packages, - In_Tree => Project_Tree); + Prj.Util.Value_Of + (Name => Name_Binder, + In_Packages => The_Packages, + In_Tree => Project_Tree); Linker_Package : constant Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Linker, - In_Packages => The_Packages, - In_Tree => Project_Tree); + Prj.Util.Value_Of + (Name => Name_Linker, + In_Packages => The_Packages, + In_Tree => Project_Tree); begin -- We fail if we cannot find the main source file diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 8feffc019c6..4050382e1c6 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -91,6 +91,9 @@ package body MLib.Prj is Compile_Switch_String : aliased String := "-c"; Compile_Switch : constant String_Access := Compile_Switch_String'Access; + No_Warning_String : aliased String := "-gnatws"; + No_Warning : constant String_Access := No_Warning_String'Access; + Auto_Initialize : constant String := "-a"; -- List of objects to put inside the library @@ -1184,8 +1187,9 @@ package body MLib.Prj is Arguments := new String_List (1 .. Initial_Argument_Max); end if; - Argument_Number := 1; + Argument_Number := 2; Arguments (1) := Compile_Switch; + Arguments (2) := No_Warning; if OpenVMS_On_Target then B_Start := new String'("b__"); @@ -1258,7 +1262,7 @@ package body MLib.Prj is -- Process binder generated file for pragmas Linker_Options - Process_Binder_File (Arguments (2).all & ASCII.NUL); + Process_Binder_File (Arguments (3).all & ASCII.NUL); end if; end if; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 2835caf0b41..566995d4cfd 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -98,6 +98,15 @@ package body Sem_Aggr is -- expressions allowed for a limited component association (namely, an -- aggregate, function call, or <> notation). Report error for violations. + procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id); + -- Given aggregate Expr, check that sub-aggregates of Expr that are nested + -- at Level are qualified. If Level = 0, this applies to Expr directly. + -- Only issue errors in formal verification mode. + + function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean; + -- Return True of Expr is an aggregate not contained directly in another + -- aggregate. + ------------------------------------------------------ -- Subprograms used for RECORD AGGREGATE Processing -- ------------------------------------------------------ @@ -789,6 +798,41 @@ package body Sem_Aggr is end if; end Check_Expr_OK_In_Limited_Aggregate; + ------------------------------- + -- Check_Qualified_Aggregate -- + ------------------------------- + + procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is + Comp_Expr : Node_Id; + Comp_Assn : Node_Id; + begin + if Level = 0 then + if Nkind (Parent (Expr)) /= N_Qualified_Expression then + Check_Formal_Restriction ("aggregate should be qualified", Expr); + end if; + else + Comp_Expr := First (Expressions (Expr)); + while Present (Comp_Expr) loop + if Nkind (Comp_Expr) = N_Aggregate then + Check_Qualified_Aggregate (Level - 1, Comp_Expr); + end if; + + Comp_Expr := Next (Comp_Expr); + end loop; + + Comp_Assn := First (Component_Associations (Expr)); + while Present (Comp_Assn) loop + Comp_Expr := Expression (Comp_Assn); + + if Nkind (Comp_Expr) = N_Aggregate then + Check_Qualified_Aggregate (Level - 1, Comp_Expr); + end if; + + Comp_Assn := Next (Comp_Assn); + end loop; + end if; + end Check_Qualified_Aggregate; + ---------------------------------------- -- Check_Static_Discriminated_Subtype -- ---------------------------------------- @@ -861,6 +905,17 @@ package body Sem_Aggr is = N_Others_Choice; end Is_Others_Aggregate; + ---------------------------- + -- Is_Top_Level_Aggregate -- + ---------------------------- + + function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean is + begin + return Nkind (Parent (Expr)) /= N_Aggregate + and then (Nkind (Parent (Expr)) /= N_Component_Association + or else Nkind (Parent (Parent (Expr))) /= N_Aggregate); + end Is_Top_Level_Aggregate; + -------------------------------- -- Make_String_Into_Aggregate -- -------------------------------- @@ -921,6 +976,39 @@ package body Sem_Aggr is return; end if; + -- An unqualified aggregate is restricted in SPARK or ALFA to: + + -- An aggregate item inside an aggregate for a multi-dimensional array + + -- An expression being assigned to an unconstrained array, but only if + -- the aggregate specifies a value for OTHERS only. + + if Nkind (Parent (N)) = N_Qualified_Expression then + if Is_Array_Type (Typ) then + Check_Qualified_Aggregate (Number_Dimensions (Typ), N); + else + Check_Qualified_Aggregate (1, N); + end if; + else + if Is_Array_Type (Typ) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then not Is_Constrained (Etype (Name (Parent (N)))) + and then not Is_Others_Aggregate (N) + then + Check_Formal_Restriction + ("array aggregate should have only OTHERS", N); + elsif Is_Top_Level_Aggregate (N) then + Check_Formal_Restriction ("aggregate should be qualified", N); + + -- The legality of this unqualified aggregate is checked by calling + -- Check_Qualified_Aggregate from one of its enclosing aggregate, + -- unless one of these already causes an error to be issued. + + else + null; + end if; + end if; + -- Check for aggregates not allowed in configurable run-time mode. -- We allow all cases of aggregates that do not come from source, since -- these are all assumed to be small (e.g. bounds of a string literal). @@ -1098,49 +1186,6 @@ package body Sem_Aggr is Error_Msg_N ("illegal context for aggregate", N); end if; - -- An unqualified aggregate is restricted in SPARK or ALFA to: - - -- An aggregate item inside an aggregate for a multi-dimensional array - - -- An expression being assigned to an unconstrained array, but only if - -- the aggregate specifies a value for OTHERS only. - - if Nkind (Parent (N)) /= N_Qualified_Expression then - if Is_Array_Type (Etype (N)) then - if Nkind (Parent (N)) = N_Assignment_Statement - and then not Is_Constrained (Etype (Name (Parent (N)))) - then - if not Is_Others_Aggregate (N) then - Check_Formal_Restriction - ("array aggregate should have only OTHERS", N); - end if; - - -- The following check is disabled until a proper place is - -- found where the type of the parent node can be inspected??? - --- elsif not (Nkind (Parent (N)) = N_Aggregate --- and then Is_Array_Type (Etype (Parent (N))) --- and then Number_Dimensions (Etype (Parent (N))) > 1) --- then --- Check_Formal_Restriction --- ("array aggregate should be qualified", N); - else - null; - end if; - - elsif Is_Record_Type (Etype (N)) then - Check_Formal_Restriction - ("record aggregate should be qualified", N); - - -- The type of aggregate is neither array nor record, so an error - -- must have occurred during resolution. Do not report an additional - -- message here. - - else - null; - end if; - end if; - -- If we can determine statically that the evaluation of the aggregate -- raises Constraint_Error, then replace the aggregate with an -- N_Raise_Constraint_Error node, but set the Etype to the right -- 2.30.2