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
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) \
-- --
-- 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- --
-- --
-- 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- --
-- --
-- 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- --
-- --
-- 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- --
-- --
-- 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- --
-- --
-- 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- --
end if;
end;
end loop;
-
end Gen_Elab_Calls_C;
----------------------
procedure Increment_Ubuf;
-- Little procedure to increment the serial number
+ --------------------
+ -- Increment_Ubuf --
+ --------------------
+
procedure Increment_Ubuf is
begin
for J in reverse Ubuf'Range loop
Write_Statement_Buffer;
end if;
end loop;
-
end Gen_Versions_Ada;
--------------------
Write_Statement_Buffer;
end if;
end loop;
-
end Gen_Versions_C;
------------------------
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
-- 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
null;
end if;
-
end Gnatbind;
Check_File (Name_Find);
end if;
end loop;
-
end Check_Linker_Options;
-----------------
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);
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).
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
loop
Option
(Current + 1 ..
- Current +
- Library_Paths.Table (Index)'Length) :=
+ Current +
+ Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index).all;
Current :=
Current +
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
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
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__");
-- 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;
-- 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 --
------------------------------------------------------
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 --
----------------------------------------
= 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 --
--------------------------------
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).
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
OSDN Git Service
