Skip to content

R
riscv-gcc-1
Commit a5fe697b by Arnaud Charlet
Options

[multiple changes] 

2011-08-02  Yannick Moy  <moy@adacore.com>

	* 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  <obry@adacore.com>

	* 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
parent bd65a2d7
Showing with 166 additions and 80 deletions
gcc/ada/ChangeLog
2011-08-02 Yannick Moy <moy@adacore.com>
* 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 <obry@adacore.com>
* 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 <moy@adacore.com>
* errout.adb, errout.ads (Check_Formal_Restriction): move procedure
from here...
* restrict.adb, restrict.ads (Check_Formal_Restriction): ...to here
......
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) \
......
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- --
......
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- --
......
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- --
......
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- --
......
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- --
......
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- --
......
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;
------------------------
......
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;
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
......
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;
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment