Skip to content

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

[multiple changes] 

2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* inline.adb: Minor reformatting.

2015-10-26  Yannick Moy  <moy@adacore.com>

	* get_spark_xrefs.adb (get_SPARK_Xrefs): Remove obsolete
	assertion.
	* lib-xref-spark_specific.adb (Traverse_Declaration_Or_Statement):
	New procedure to factor duplicated code and add
	treatment of protected entries.
	(Add_SPARK_Scope, Traverse_Declarations_Or_Statements): Call the new
	procedure Traverse_Declaration_Or_Statement. Use same character used in
	normal xrefs for SPARK xrefs, for a given entity used as scope.
	* spark_xrefs.ads Document character used for entries.
	* sem_prag.adb (Check_Loop_Pragma_Placement): Account for possible
	introduction of declarations and statements by the expansion, between
	two otherwise consecutive loop pragmas.
	* sem_util.ads, sem_util.adb (Is_Suspension_Object): Lifted from nested
	function.
	(Is_Descendant_Of_Suspension_Object): nested function lifted.

2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_attr.adb (Eval_Attribute): Attribute 'Enum_Rep can be folded
	when its prefix denotes a constant, an enumeration literal or
	an enumeration type. Use the expression of the attribute in the
	enumeration type form, otherwise use the prefix to fold.

From-SVN: r229334
parent f99ff327
Showing with 214 additions and 164 deletions
gcc/ada/ChangeLog
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com>
* inline.adb: Minor reformatting.
2015-10-26 Yannick Moy <moy@adacore.com>
* get_spark_xrefs.adb (get_SPARK_Xrefs): Remove obsolete
assertion.
* lib-xref-spark_specific.adb (Traverse_Declaration_Or_Statement):
New procedure to factor duplicated code and add
treatment of protected entries.
(Add_SPARK_Scope, Traverse_Declarations_Or_Statements): Call the new
procedure Traverse_Declaration_Or_Statement. Use same character used in
normal xrefs for SPARK xrefs, for a given entity used as scope.
* spark_xrefs.ads Document character used for entries.
* sem_prag.adb (Check_Loop_Pragma_Placement): Account for possible
introduction of declarations and statements by the expansion, between
two otherwise consecutive loop pragmas.
* sem_util.ads, sem_util.adb (Is_Suspension_Object): Lifted from nested
function.
(Is_Descendant_Of_Suspension_Object): nested function lifted.
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.adb (Eval_Attribute): Attribute 'Enum_Rep can be folded
when its prefix denotes a constant, an enumeration literal or
an enumeration type. Use the expression of the attribute in the
enumeration type form, otherwise use the prefix to fold.
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.adb Add an entry for entry bodies in table
Has_Aspect_Specifications_Flag.
(Aspects_On_Body_Or_Stub_OK): Entry bodies now allow for certain
......
gcc/ada/get_spark_xrefs.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -293,9 +293,6 @@ begin
Col := Get_Nat;
pragma Assert (Scope = Cur_Scope);
pragma Assert (Typ = 'K'
or else Typ = 'V'
or else Typ = 'U');
-- Scan out scope entity name
......
gcc/ada/inline.adb
......@@ -3462,14 +3462,12 @@ package body Inline is
if Nkind (D) = N_Package_Declaration then
Cannot_Inline
("cannot inline & (nested package declaration)?",
D, Subp);
("cannot inline & (nested package declaration)?", D, Subp);
return True;
elsif Nkind (D) = N_Package_Instantiation then
Cannot_Inline
("cannot inline & (nested package instantiation)?",
D, Subp);
("cannot inline & (nested package instantiation)?", D, Subp);
return True;
end if;
......@@ -3482,8 +3480,7 @@ package body Inline is
or else Nkind (D) = N_Single_Task_Declaration
then
Cannot_Inline
("cannot inline & (nested task type declaration)?",
D, Subp);
("cannot inline & (nested task type declaration)?", D, Subp);
return True;
elsif Nkind (D) = N_Protected_Type_Declaration
......@@ -3496,22 +3493,19 @@ package body Inline is
elsif Nkind (D) = N_Subprogram_Body then
Cannot_Inline
("cannot inline & (nested subprogram)?",
D, Subp);
("cannot inline & (nested subprogram)?", D, Subp);
return True;
elsif Nkind (D) = N_Function_Instantiation
and then not Is_Unchecked_Conversion (D)
then
Cannot_Inline
("cannot inline & (nested function instantiation)?",
D, Subp);
("cannot inline & (nested function instantiation)?", D, Subp);
return True;
elsif Nkind (D) = N_Procedure_Instantiation then
Cannot_Inline
("cannot inline & (nested procedure instantiation)?",
D, Subp);
("cannot inline & (nested procedure instantiation)?", D, Subp);
return True;
-- Subtype declarations with predicates will generate predicate
......@@ -3535,9 +3529,8 @@ package body Inline is
or else A_Id = Aspect_Dynamic_Predicate
then
Cannot_Inline
("cannot inline & "
& "(subtype declaration with predicate)?",
D, Subp);
("cannot inline & (subtype declaration with "
& "predicate)?", D, Subp);
return True;
end if;
......
gcc/ada/lib-xref-spark_specific.adb
......@@ -104,6 +104,10 @@ package body SPARK_Specific is
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table
procedure Traverse_Declaration_Or_Statement
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
Process : Node_Processing;
......@@ -243,6 +247,11 @@ package body SPARK_Specific is
procedure Add_SPARK_Scope (N : Node_Id) is
E : constant Entity_Id := Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (E);
-- The character describing the kind of scope is chosen to be the same
-- as the one describing the corresponding entity in cross references,
-- see Xref_Entity_Letters in lib-xrefs.ads
Typ : Character;
begin
......@@ -253,39 +262,25 @@ package body SPARK_Specific is
end if;
case Ekind (E) is
when E_Function | E_Generic_Function =>
Typ := 'V';
when E_Procedure | E_Generic_Procedure =>
Typ := 'U';
when E_Subprogram_Body =>
declare
Spec : Node_Id;
begin
Spec := Parent (E);
if Nkind (Spec) = N_Defining_Program_Unit_Name then
Spec := Parent (Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
Typ := 'V';
else
pragma Assert
(Nkind (Spec) = N_Procedure_Specification);
Typ := 'U';
end if;
end;
when E_Package | E_Package_Body | E_Generic_Package =>
Typ := 'K';
when E_Entry
| E_Function
| E_Generic_Function
| E_Generic_Package
| E_Generic_Procedure
| E_Package
| E_Procedure
=>
Typ := Xref_Entity_Letters (Ekind (E));
when E_Package_Body
| E_Subprogram_Body
=>
Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
when E_Void =>
-- Compilation of prj-attr.adb with -gnatn creates a node with
-- entity E_Void for the package defined at a-charac.ads16:13
-- Compilation of prj-attr.adb with -gnatn creates a node with
-- entity E_Void for the package defined at a-charac.ads16:13.
-- ??? TBD
return;
......@@ -968,11 +963,14 @@ package body SPARK_Specific is
procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
begin
if Nkind_In (N, N_Subprogram_Declaration,
if Nkind_In (N, N_Entry_Body,
N_Entry_Declaration,
N_Package_Body,
N_Package_Body_Stub,
N_Package_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Package_Declaration,
N_Package_Body)
N_Subprogram_Declaration)
then
Add_SPARK_Scope (N);
end if;
......@@ -1193,63 +1191,23 @@ package body SPARK_Specific is
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu, Process, Inside_Stubs);
elsif Nkind (Lu) = N_Subprogram_Declaration then
null;
elsif Nkind (Lu) = N_Package_Declaration then
Traverse_Package_Declaration (Lu, Process, Inside_Stubs);
elsif Nkind (Lu) = N_Package_Body then
Traverse_Package_Body (Lu, Process, Inside_Stubs);
elsif Nkind (Lu) = N_Protected_Body then
Traverse_Protected_Body (Lu, Process, Inside_Stubs);
-- All other cases of compilation units (e.g. renamings), are not
-- declarations, or else generic declarations which are ignored.
else
null;
end if;
Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs);
end Traverse_Compilation_Unit;
-----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
---------------------------------------
-- Traverse_Declaration_Or_Statement --
---------------------------------------
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
procedure Traverse_Declaration_Or_Statement
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
N : Node_Id;
begin
-- Loop through statements or declarations
N := First (L);
while Present (N) loop
-- Call Process on all declarations
if Nkind (N) in N_Declaration
or else
Nkind (N) in N_Later_Decl_Item
then
Process (N);
end if;
case Nkind (N) is
-- Package declaration
when N_Package_Declaration =>
Traverse_Package_Declaration (N, Process, Inside_Stubs);
-- Package body
when N_Package_Body =>
if Ekind (Defining_Entity (N)) /= E_Generic_Package then
Traverse_Package_Body (N, Process, Inside_Stubs);
......@@ -1269,14 +1227,12 @@ package body SPARK_Specific is
end;
end if;
-- Subprogram declaration
when N_Subprogram_Declaration =>
null;
-- Subprogram body
when N_Subprogram_Body =>
when N_Entry_Body
| N_Subprogram_Body
=>
if not Is_Generic_Subprogram (Defining_Entity (N)) then
Traverse_Subprogram_Body (N, Process, Inside_Stubs);
end if;
......@@ -1290,14 +1246,11 @@ package body SPARK_Specific is
and then
not Is_Generic_Subprogram (Defining_Entity (Body_N))
then
Traverse_Subprogram_Body
(Body_N, Process, Inside_Stubs);
Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
end if;
end;
end if;
-- Protected unit
when N_Protected_Definition =>
Traverse_Declarations_Or_Statements
(Visible_Declarations (N), Process, Inside_Stubs);
......@@ -1319,8 +1272,6 @@ package body SPARK_Specific is
end;
end if;
-- Task unit
when N_Task_Definition =>
Traverse_Declarations_Or_Statements
(Visible_Declarations (N), Process, Inside_Stubs);
......@@ -1348,8 +1299,6 @@ package body SPARK_Specific is
end;
end if;
-- Block statement
when N_Block_Statement =>
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
......@@ -1383,8 +1332,6 @@ package body SPARK_Specific is
Traverse_Declarations_Or_Statements
(Else_Statements (N), Process, Inside_Stubs);
-- Case statement
when N_Case_Statement =>
-- Process case branches
......@@ -1400,14 +1347,10 @@ package body SPARK_Specific is
end loop;
end;
-- Extended return statement
when N_Extended_Return_Statement =>
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
-- Loop
when N_Loop_Statement =>
Traverse_Declarations_Or_Statements
(Statements (N), Process, Inside_Stubs);
......@@ -1417,6 +1360,34 @@ package body SPARK_Specific is
when others =>
null;
end case;
end Traverse_Declaration_Or_Statement;
-----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
Process : Node_Processing;
Inside_Stubs : Boolean)
is
N : Node_Id;
begin
-- Loop through statements or declarations
N := First (L);
while Present (N) loop
-- Call Process on all declarations
if Nkind (N) in N_Declaration
or else
Nkind (N) in N_Later_Decl_Item
then
Process (N);
end if;
Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs);
Next (N);
end loop;
......
gcc/ada/sem_attr.adb
......@@ -7265,20 +7265,58 @@ package body Sem_Attr is
return;
end if;
-- Special processing for cases where the prefix is an object. For
-- this purpose, a string literal counts as an object (attributes
-- of string literals can only appear in generated code).
-- Special processing for cases where the prefix is an object. For this
-- purpose, a string literal counts as an object (attributes of string
-- literals can only appear in generated code).
if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
-- For Component_Size, the prefix is an array object, and we apply
-- the attribute to the type of the object. This is allowed for
-- both unconstrained and constrained arrays, since the bounds
-- have no influence on the value of this attribute.
-- the attribute to the type of the object. This is allowed for both
-- unconstrained and constrained arrays, since the bounds have no
-- influence on the value of this attribute.
if Id = Attribute_Component_Size then
P_Entity := Etype (P);
-- For Enum_Rep, evaluation depends on the nature of the prefix and
-- the optional argument.
elsif Id = Attribute_Enum_Rep then
if Is_Entity_Name (P) then
-- The prefix denotes a constant or an enumeration literal, the
-- attribute can be folded.
if Ekind_In (Entity (P), E_Constant, E_Enumeration_Literal) then
P_Entity := Etype (P);
-- The prefix denotes an enumeration type. Folding can occur
-- when the argument is a constant or an enumeration literal.
elsif Is_Enumeration_Type (Entity (P))
and then Present (E1)
and then Is_Entity_Name (E1)
and then Ekind_In (Entity (E1), E_Constant,
E_Enumeration_Literal)
then
P_Entity := Etype (P);
-- Otherwise the attribute must be expanded into a conversion
-- and evaluated at runtime.
else
Check_Expressions;
return;
end if;
-- Otherwise the attribute is illegal, do not attempt to perform
-- any kind of folding.
else
return;
end if;
-- For First and Last, the prefix is an array object, and we apply
-- the attribute to the type of the array, but we need a constrained
-- type for this, so we use the actual subtype if available.
......@@ -7971,7 +8009,26 @@ package body Sem_Attr is
-- Enum_Rep --
--------------
when Attribute_Enum_Rep =>
when Attribute_Enum_Rep => Enum_Rep : declare
Val : Node_Id;
begin
-- The attribute appears in the form
-- Enum_Typ'Enum_Rep (Const)
-- Enum_Typ'Enum_Rep (Enum_Lit)
if Present (E1) then
Val := E1;
-- Otherwise the prefix denotes a constant or enumeration literal
-- Const'Enum_Rep
-- Enum_Lit'Enum_Rep
else
Val := P;
end if;
-- For an enumeration type with a non-standard representation use
-- the Enumeration_Rep field of the proper constant. Note that this
......@@ -7983,15 +8040,16 @@ package body Sem_Attr is
if Is_Enumeration_Type (P_Type)
and then Has_Non_Standard_Rep (P_Type)
then
Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static);
-- For enumeration types with standard representations and all
-- other cases (i.e. all integer and modular types), Enum_Rep
-- is equivalent to Pos.
-- For enumeration types with standard representations and all other
-- cases (i.e. all integer and modular types), Enum_Rep is equivalent
-- to Pos.
else
Fold_Uint (N, Expr_Value (E1), Static);
Fold_Uint (N, Expr_Value (Val), Static);
end if;
end Enum_Rep;
--------------
-- Enum_Val --
......
gcc/ada/sem_prag.adb
......@@ -4833,6 +4833,12 @@ package body Sem_Prag is
elsif Is_Loop_Pragma (Stmt) then
Prag := Stmt;
-- Skip declarations and statements generated by
-- the compiler during expansion.
elsif not Comes_From_Source (Stmt) then
null;
-- A non-pragma is separating the group from the
-- current pragma, the placement is illegal.
......
gcc/ada/sem_util.adb
......@@ -11309,40 +11309,9 @@ package body Sem_Util is
function Is_Descendant_Of_Suspension_Object
(Typ : Entity_Id) return Boolean
is
function Is_Suspension_Object (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes Suspension_Object
-- defined in Ada.Synchronous_Task_Control.
--------------------------
-- Is_Suspension_Object --
--------------------------
function Is_Suspension_Object (Id : Entity_Id) return Boolean is
begin
-- This approach does an exact name match rather than to rely on
-- RTSfind. Routine Is_Effectively_Volatile is used by clients of
-- the front end at point where all auxiliary tables are locked
-- and any modifications to them are treated as violations. Do not
-- tamper with the tables, instead examine the Chars fields of all
-- the scopes of Id.
return
Chars (Id) = Name_Suspension_Object
and then Present (Scope (Id))
and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
and then Present (Scope (Scope (Id)))
and then Chars (Scope (Scope (Id))) = Name_Ada
and then Present (Scope (Scope (Scope (Id))))
and then Scope (Scope (Scope (Id))) = Standard_Standard;
end Is_Suspension_Object;
-- Local variables
Cur_Typ : Entity_Id;
Par_Typ : Entity_Id;
-- Start of processing for Is_Descendant_Of_Suspension_Object
begin
-- Climb the type derivation chain checking each parent type against
-- Suspension_Object.
......@@ -13161,6 +13130,28 @@ package body Sem_Util is
and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
end Is_Subprogram_Stub_Without_Prior_Declaration;
--------------------------
-- Is_Suspension_Object --
--------------------------
function Is_Suspension_Object (Id : Entity_Id) return Boolean is
begin
-- This approach does an exact name match rather than to rely on
-- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
-- front end at point where all auxiliary tables are locked and any
-- modifications to them are treated as violations. Do not tamper with
-- the tables, instead examine the Chars fields of all the scopes of Id.
return
Chars (Id) = Name_Suspension_Object
and then Present (Scope (Id))
and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
and then Present (Scope (Scope (Id)))
and then Chars (Scope (Scope (Id))) = Name_Ada
and then Present (Scope (Scope (Scope (Id))))
and then Scope (Scope (Scope (Id))) = Standard_Standard;
end Is_Suspension_Object;
---------------------------------
-- Is_Synchronized_Tagged_Type --
---------------------------------
......
gcc/ada/sem_util.ads
......@@ -1503,6 +1503,10 @@ package Sem_Util is
-- Return True if N is a subprogram stub with no prior subprogram
-- declaration.
function Is_Suspension_Object (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes Suspension_Object defined
-- in Ada.Synchronous_Task_Control.
function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean;
-- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2))
......
gcc/ada/spark_xrefs.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -111,9 +111,10 @@ package SPARK_Xrefs is
-- type is a single letter identifying the type of the entity, using
-- the same code as in cross-references:
-- K = package
-- V = function
-- U = procedure
-- K = package (k = generic package)
-- V = function (v = generic function)
-- U = procedure (u = generic procedure)
-- Y = entry
-- col is the column number of the scope entity
......
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