Skip to content

R
riscv-gcc-1
Commit 4169c2d2 by Arnaud Charlet
Options

[multiple changes] 

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Refined_Pre and Refined_Post are now allowed as
	assertion identifiers for pragma Assertion_Policy.
	* sem_prag.adb (Is_Valid_Assertion_Kind): Add Refined_Pre/Refined_Post
	* sem_ch13.adb: Minor reformatting.

2013-10-10  Pascal Obry  <obry@adacore.com>

	* prj-conf.adb: Code refactoring.

From-SVN: r203361
parent aa500b7a
Showing with 197 additions and 177 deletions
gcc/ada/ChangeLog
2013-10-10 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Refined_Pre and Refined_Post are now allowed as
assertion identifiers for pragma Assertion_Policy.
* sem_prag.adb (Is_Valid_Assertion_Kind): Add Refined_Pre/Refined_Post
* sem_ch13.adb: Minor reformatting.
2013-10-10 Pascal Obry <obry@adacore.com>
* prj-conf.adb: Code refactoring.
2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Remove Integrity_Level from the node usage list.
......
gcc/ada/gnat_rm.texi
......@@ -1375,7 +1375,9 @@ ID_ASSERTION_KIND ::= Assertions |
Loop_Variant |
Postcondition |
Precondition |
Predicate
Predicate |
Refined_Post |
Refined_Pre |
Statement_Assertions
POLICY_IDENTIFIER ::= Check | Disable | Ignore
......
gcc/ada/prj-conf.adb
......@@ -68,16 +68,6 @@ package body Prj.Conf is
-- Local_Subprograms --
-----------------------
procedure Add_Attributes
(Project_Tree : Project_Tree_Ref;
Conf_Decl : Declarations;
User_Decl : in out Declarations);
-- Process the attributes in the config declarations.
-- For single string values, if the attribute is not declared in the user
-- declarations, declare it with the value in the config declarations.
-- For string list values, prepend the value in the user declarations with
-- the value in the config declarations.
function Check_Target
(Config_File : Prj.Project_Id;
Autoconf_Specified : Boolean;
......@@ -109,6 +99,159 @@ package body Prj.Conf is
-- projects, so that when the second phase of the processing is performed
-- these attributes are automatically taken into account.
------------------------------------
-- Add_Default_GNAT_Naming_Scheme --
------------------------------------
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Project_Node_Id;
Project_Tree : Project_Node_Tree_Ref)
is
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node);
----------------------
-- Create_Attribute --
----------------------
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node)
is
Attr : Project_Node_Id;
pragma Unreferenced (Attr);
Expr : Name_Id := No_Name;
Val : Name_Id := No_Name;
Parent : Project_Node_Id := Config_File;
begin
if Index /= "" then
Name_Len := Index'Length;
Name_Buffer (1 .. Name_Len) := Index;
Val := Name_Find;
end if;
if Pkg /= Empty_Node then
Parent := Pkg;
end if;
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
Expr := Name_Find;
Attr := Create_Attribute
(Tree => Project_Tree,
Prj_Or_Pkg => Parent,
Name => Name,
Index_Name => Val,
Kind => Prj.Single,
Value => Create_Literal_String (Expr, Project_Tree));
end Create_Attribute;
-- Local variables
Name : Name_Id;
Naming : Project_Node_Id;
Compiler : Project_Node_Id;
-- Start of processing for Add_Default_GNAT_Naming_Scheme
begin
if Config_File = Empty_Node then
-- Create a dummy config file is none was found
Name_Len := Auto_Cgpr'Length;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
Name := Name_Find;
-- An invalid project name to avoid conflicts with user-created ones
Name_Len := 5;
Name_Buffer (1 .. Name_Len) := "_auto";
Config_File :=
Create_Project
(In_Tree => Project_Tree,
Name => Name_Find,
Full_Path => Path_Name_Type (Name),
Is_Config_File => True);
-- Setup library support
case MLib.Tgt.Support_For_Libraries is
when None =>
null;
when Static_Only =>
Create_Attribute (Name_Library_Support, "static_only");
when Full =>
Create_Attribute (Name_Library_Support, "full");
end case;
if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
Create_Attribute (Name_Library_Auto_Init_Supported, "true");
else
Create_Attribute (Name_Library_Auto_Init_Supported, "false");
end if;
-- Setup Ada support (Ada is the default language here, since this
-- is only called when no config file existed initially, ie for
-- gnatmake).
Create_Attribute (Name_Default_Language, "ada");
Compiler := Create_Package (Project_Tree, Config_File, "compiler");
Create_Attribute
(Name_Driver, "gcc", "ada", Pkg => Compiler);
Create_Attribute
(Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
Create_Attribute
(Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
Naming := Create_Package (Project_Tree, Config_File, "naming");
Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
if Current_Verbosity = High then
Write_Line ("Automatically generated (in-memory) config file");
Prj.PP.Pretty_Print
(Project => Config_File,
In_Tree => Project_Tree,
Backward_Compatibility => False);
end if;
end if;
end Add_Default_GNAT_Naming_Scheme;
-----------------------
-- Apply_Config_File --
-----------------------
procedure Apply_Config_File
(Config_File : Prj.Project_Id;
Project_Tree : Prj.Project_Tree_Ref)
is
procedure Add_Attributes
(Project_Tree : Project_Tree_Ref;
Conf_Decl : Declarations;
User_Decl : in out Declarations);
-- Process the attributes in the config declarations. For
-- single string values, if the attribute is not declared in
-- the user declarations, declare it with the value in the
-- config declarations. For string list values, prepend the
-- value in the user declarations with the value in the config
-- declarations.
--------------------
-- Add_Attributes --
--------------------
......@@ -118,7 +261,8 @@ package body Prj.Conf is
Conf_Decl : Declarations;
User_Decl : in out Declarations)
is
Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
Shared : constant Shared_Project_Tree_Data_Access :=
Project_Tree.Shared;
Conf_Attr_Id : Variable_Id;
Conf_Attr : Variable;
Conf_Array_Id : Array_Id;
......@@ -138,6 +282,7 @@ package body Prj.Conf is
begin
Conf_Attr_Id := Conf_Decl.Attributes;
User_Attr_Id := User_Decl.Attributes;
while Conf_Attr_Id /= No_Variable loop
Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
......@@ -145,8 +290,8 @@ package body Prj.Conf is
if not Conf_Attr.Value.Default then
if User_Attr.Value.Default then
-- No attribute declared in user project file: just copy the
-- value of the configuration attribute.
-- No attribute declared in user project file: just copy
-- the value of the configuration attribute.
User_Attr.Value := Conf_Attr.Value;
Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
......@@ -177,7 +322,8 @@ package body Prj.Conf is
-- Value of attribute is new list
User_Attr.Value.Values := New_List;
Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
Shared.Variable_Elements.Table (User_Attr_Id) :=
User_Attr;
loop
-- Get each element of configuration list
......@@ -188,21 +334,21 @@ package body Prj.Conf is
if Conf_List = Nil_String then
-- If it is the last element in the list, connect to
-- first element of user list, and we are done.
-- If it is the last element in the list, connect
-- to first element of user list, and we are done.
New_Elem.Next := User_List;
Shared.String_Elements.Table (New_List) := New_Elem;
exit;
else
-- If it is not the last element in the list, add to
-- new list.
-- If it is not the last element in the list, add
-- to new list.
String_Element_Table.Increment_Last
(Shared.String_Elements);
New_Elem.Next :=
String_Element_Table.Last (Shared.String_Elements);
New_Elem.Next := String_Element_Table.Last
(Shared.String_Elements);
Shared.String_Elements.Table (New_List) := New_Elem;
New_List := New_Elem.Next;
end if;
......@@ -226,8 +372,8 @@ package body Prj.Conf is
User_Array_Id := User_Array.Next;
end loop;
-- If this associative array does not exist in the user project file,
-- do a shallow copy of the full associative array.
-- If this associative array does not exist in the user project
-- file, do a shallow copy of the full associative array.
if User_Array_Id = No_Array then
Array_Table.Increment_Last (Shared.Arrays);
......@@ -252,11 +398,13 @@ package body Prj.Conf is
User_Array_Elem_Id := User_Array_Elem.Next;
end loop;
-- If the array element doesn't exist in the user array, insert
-- a shallow copy of the conf array element in the user array.
-- If the array element doesn't exist in the user array,
-- insert a shallow copy of the conf array element in the
-- user array.
if User_Array_Elem_Id = No_Array_Element then
Array_Element_Table.Increment_Last (Shared.Array_Elements);
Array_Element_Table.Increment_Last
(Shared.Array_Elements);
User_Array_Elem := Conf_Array_Elem;
User_Array_Elem.Next := User_Array.Value;
User_Array.Value :=
......@@ -265,8 +413,8 @@ package body Prj.Conf is
User_Array_Elem;
Shared.Arrays.Table (User_Array_Id) := User_Array;
-- Otherwise, if the value is a string list, prepend the conf
-- array element value to the array element.
-- Otherwise, if the value is a string list, prepend the
-- conf array element value to the array element.
elsif Conf_Array_Elem.Value.Kind = List then
Conf_List := Conf_Array_Elem.Value.Values;
......@@ -305,8 +453,8 @@ package body Prj.Conf is
Conf_List := Conf_List_Elem.Next;
if Conf_List = Nil_String then
Shared.String_Elements.Table (Previous).Next :=
Link;
Shared.String_Elements.Table
(Previous).Next := Link;
exit;
end if;
end loop;
......@@ -322,148 +470,6 @@ package body Prj.Conf is
end loop;
end Add_Attributes;
------------------------------------
-- Add_Default_GNAT_Naming_Scheme --
------------------------------------
procedure Add_Default_GNAT_Naming_Scheme
(Config_File : in out Project_Node_Id;
Project_Tree : Project_Node_Tree_Ref)
is
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node);
----------------------
-- Create_Attribute --
----------------------
procedure Create_Attribute
(Name : Name_Id;
Value : String;
Index : String := "";
Pkg : Project_Node_Id := Empty_Node)
is
Attr : Project_Node_Id;
pragma Unreferenced (Attr);
Expr : Name_Id := No_Name;
Val : Name_Id := No_Name;
Parent : Project_Node_Id := Config_File;
begin
if Index /= "" then
Name_Len := Index'Length;
Name_Buffer (1 .. Name_Len) := Index;
Val := Name_Find;
end if;
if Pkg /= Empty_Node then
Parent := Pkg;
end if;
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
Expr := Name_Find;
Attr := Create_Attribute
(Tree => Project_Tree,
Prj_Or_Pkg => Parent,
Name => Name,
Index_Name => Val,
Kind => Prj.Single,
Value => Create_Literal_String (Expr, Project_Tree));
end Create_Attribute;
-- Local variables
Name : Name_Id;
Naming : Project_Node_Id;
Compiler : Project_Node_Id;
-- Start of processing for Add_Default_GNAT_Naming_Scheme
begin
if Config_File = Empty_Node then
-- Create a dummy config file is none was found
Name_Len := Auto_Cgpr'Length;
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
Name := Name_Find;
-- An invalid project name to avoid conflicts with user-created ones
Name_Len := 5;
Name_Buffer (1 .. Name_Len) := "_auto";
Config_File :=
Create_Project
(In_Tree => Project_Tree,
Name => Name_Find,
Full_Path => Path_Name_Type (Name),
Is_Config_File => True);
-- Setup library support
case MLib.Tgt.Support_For_Libraries is
when None =>
null;
when Static_Only =>
Create_Attribute (Name_Library_Support, "static_only");
when Full =>
Create_Attribute (Name_Library_Support, "full");
end case;
if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
Create_Attribute (Name_Library_Auto_Init_Supported, "true");
else
Create_Attribute (Name_Library_Auto_Init_Supported, "false");
end if;
-- Setup Ada support (Ada is the default language here, since this
-- is only called when no config file existed initially, ie for
-- gnatmake).
Create_Attribute (Name_Default_Language, "ada");
Compiler := Create_Package (Project_Tree, Config_File, "compiler");
Create_Attribute
(Name_Driver, "gcc", "ada", Pkg => Compiler);
Create_Attribute
(Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
Create_Attribute
(Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
Naming := Create_Package (Project_Tree, Config_File, "naming");
Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
if Current_Verbosity = High then
Write_Line ("Automatically generated (in-memory) config file");
Prj.PP.Pretty_Print
(Project => Config_File,
In_Tree => Project_Tree,
Backward_Compatibility => False);
end if;
end if;
end Add_Default_GNAT_Naming_Scheme;
-----------------------
-- Apply_Config_File --
-----------------------
procedure Apply_Config_File
(Config_File : Prj.Project_Id;
Project_Tree : Prj.Project_Tree_Ref)
is
Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
Conf_Decl : constant Declarations := Config_File.Decl;
......
gcc/ada/sem_ch13.adb
......@@ -1383,9 +1383,8 @@ package body Sem_Ch13 is
pragma Assert (not Is_Disabled (Aspect));
-- Certan aspects allow for an optional name or expression. Do
-- not generate a pragma with an empty argument association
-- list.
-- Certain aspects allow for an optional name or expression. Do
-- not generate a pragma with empty argument association list.
if No (Args) or else No (Expression (First (Args))) then
Args := No_List;
......
gcc/ada/sem_prag.adb
......@@ -9127,10 +9127,10 @@ package body Sem_Prag is
-- Postcondition |
-- Precondition |
-- Predicate |
-- Refined_Post |
-- Refined_Pre |
-- Statement_Assertions
-- Shouldn't Refined_Pre be in this list???
-- Note: The RM_ASSERTION_KIND list is language-defined, and the
-- ID_ASSERTION_KIND list contains implementation-defined additions
-- recognized by GNAT. The effect is to control the behavior of
......@@ -19482,6 +19482,8 @@ package body Sem_Prag is
Name_Postcondition |
Name_Precondition |
Name_Predicate |
Name_Refined_Post |
Name_Refined_Pre |
Name_Statement_Assertions => return True;
when others => return False;
......
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