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 333 additions and 283 deletions
gcc/ada/ChangeLog
2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> 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 * aspects.adb Add an entry for entry bodies in table
Has_Aspect_Specifications_Flag. Has_Aspect_Specifications_Flag.
(Aspects_On_Body_Or_Stub_OK): Entry bodies now allow for certain (Aspects_On_Body_Or_Stub_OK): Entry bodies now allow for certain
......
gcc/ada/get_spark_xrefs.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -293,9 +293,6 @@ begin ...@@ -293,9 +293,6 @@ begin
Col := Get_Nat; Col := Get_Nat;
pragma Assert (Scope = Cur_Scope); pragma Assert (Scope = Cur_Scope);
pragma Assert (Typ = 'K'
or else Typ = 'V'
or else Typ = 'U');
-- Scan out scope entity name -- Scan out scope entity name
......
gcc/ada/inline.adb
...@@ -3462,14 +3462,12 @@ package body Inline is ...@@ -3462,14 +3462,12 @@ package body Inline is
if Nkind (D) = N_Package_Declaration then if Nkind (D) = N_Package_Declaration then
Cannot_Inline Cannot_Inline
("cannot inline & (nested package declaration)?", ("cannot inline & (nested package declaration)?", D, Subp);
D, Subp);
return True; return True;
elsif Nkind (D) = N_Package_Instantiation then elsif Nkind (D) = N_Package_Instantiation then
Cannot_Inline Cannot_Inline
("cannot inline & (nested package instantiation)?", ("cannot inline & (nested package instantiation)?", D, Subp);
D, Subp);
return True; return True;
end if; end if;
...@@ -3482,8 +3480,7 @@ package body Inline is ...@@ -3482,8 +3480,7 @@ package body Inline is
or else Nkind (D) = N_Single_Task_Declaration or else Nkind (D) = N_Single_Task_Declaration
then then
Cannot_Inline Cannot_Inline
("cannot inline & (nested task type declaration)?", ("cannot inline & (nested task type declaration)?", D, Subp);
D, Subp);
return True; return True;
elsif Nkind (D) = N_Protected_Type_Declaration elsif Nkind (D) = N_Protected_Type_Declaration
...@@ -3496,22 +3493,19 @@ package body Inline is ...@@ -3496,22 +3493,19 @@ package body Inline is
elsif Nkind (D) = N_Subprogram_Body then elsif Nkind (D) = N_Subprogram_Body then
Cannot_Inline Cannot_Inline
("cannot inline & (nested subprogram)?", ("cannot inline & (nested subprogram)?", D, Subp);
D, Subp);
return True; return True;
elsif Nkind (D) = N_Function_Instantiation elsif Nkind (D) = N_Function_Instantiation
and then not Is_Unchecked_Conversion (D) and then not Is_Unchecked_Conversion (D)
then then
Cannot_Inline Cannot_Inline
("cannot inline & (nested function instantiation)?", ("cannot inline & (nested function instantiation)?", D, Subp);
D, Subp);
return True; return True;
elsif Nkind (D) = N_Procedure_Instantiation then elsif Nkind (D) = N_Procedure_Instantiation then
Cannot_Inline Cannot_Inline
("cannot inline & (nested procedure instantiation)?", ("cannot inline & (nested procedure instantiation)?", D, Subp);
D, Subp);
return True; return True;
-- Subtype declarations with predicates will generate predicate -- Subtype declarations with predicates will generate predicate
...@@ -3535,9 +3529,8 @@ package body Inline is ...@@ -3535,9 +3529,8 @@ package body Inline is
or else A_Id = Aspect_Dynamic_Predicate or else A_Id = Aspect_Dynamic_Predicate
then then
Cannot_Inline Cannot_Inline
("cannot inline & " ("cannot inline & (subtype declaration with "
& "(subtype declaration with predicate)?", & "predicate)?", D, Subp);
D, Subp);
return True; return True;
end if; end if;
......
gcc/ada/lib-xref-spark_specific.adb
...@@ -104,6 +104,10 @@ package body SPARK_Specific is ...@@ -104,6 +104,10 @@ package body SPARK_Specific is
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table -- Hash function for hash table
procedure Traverse_Declaration_Or_Statement
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Declarations_Or_Statements procedure Traverse_Declarations_Or_Statements
(L : List_Id; (L : List_Id;
Process : Node_Processing; Process : Node_Processing;
...@@ -243,6 +247,11 @@ package body SPARK_Specific is ...@@ -243,6 +247,11 @@ package body SPARK_Specific is
procedure Add_SPARK_Scope (N : Node_Id) is procedure Add_SPARK_Scope (N : Node_Id) is
E : constant Entity_Id := Defining_Entity (N); E : constant Entity_Id := Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (E); 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; Typ : Character;
begin begin
...@@ -253,39 +262,25 @@ package body SPARK_Specific is ...@@ -253,39 +262,25 @@ package body SPARK_Specific is
end if; end if;
case Ekind (E) is case Ekind (E) is
when E_Function | E_Generic_Function => when E_Entry
Typ := 'V'; | E_Function
| E_Generic_Function
when E_Procedure | E_Generic_Procedure => | E_Generic_Package
Typ := 'U'; | E_Generic_Procedure
| E_Package
when E_Subprogram_Body => | E_Procedure
declare =>
Spec : Node_Id; Typ := Xref_Entity_Letters (Ekind (E));
begin when E_Package_Body
Spec := Parent (E); | E_Subprogram_Body
=>
if Nkind (Spec) = N_Defining_Program_Unit_Name then Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
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_Void => 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 -- ??? TBD
return; return;
...@@ -968,11 +963,14 @@ package body SPARK_Specific is ...@@ -968,11 +963,14 @@ package body SPARK_Specific is
procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
begin 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,
N_Subprogram_Body_Stub, N_Subprogram_Body_Stub,
N_Package_Declaration, N_Subprogram_Declaration)
N_Package_Body)
then then
Add_SPARK_Scope (N); Add_SPARK_Scope (N);
end if; end if;
...@@ -1193,230 +1191,203 @@ package body SPARK_Specific is ...@@ -1193,230 +1191,203 @@ package body SPARK_Specific is
-- Traverse the unit -- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs);
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;
end Traverse_Compilation_Unit; end Traverse_Compilation_Unit;
----------------------------------------- ---------------------------------------
-- Traverse_Declarations_Or_Statements -- -- Traverse_Declaration_Or_Statement --
----------------------------------------- ---------------------------------------
procedure Traverse_Declarations_Or_Statements procedure Traverse_Declaration_Or_Statement
(L : List_Id; (N : Node_Id;
Process : Node_Processing; Process : Node_Processing;
Inside_Stubs : Boolean) Inside_Stubs : Boolean)
is is
N : Node_Id;
begin begin
-- Loop through statements or declarations case Nkind (N) is
when N_Package_Declaration =>
N := First (L); Traverse_Package_Declaration (N, Process, Inside_Stubs);
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);
end if;
when N_Package_Body_Stub => when N_Package_Body =>
if Present (Library_Unit (N)) then if Ekind (Defining_Entity (N)) /= E_Generic_Package then
declare Traverse_Package_Body (N, Process, Inside_Stubs);
Body_N : constant Node_Id := Get_Body_From_Stub (N); end if;
begin
if Inside_Stubs
and then
Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
then
Traverse_Package_Body (Body_N, Process, Inside_Stubs);
end if;
end;
end if;
-- Subprogram declaration
when N_Subprogram_Declaration => when N_Package_Body_Stub =>
null; if Present (Library_Unit (N)) then
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
if Inside_Stubs
and then
Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
then
Traverse_Package_Body (Body_N, Process, Inside_Stubs);
end if;
end;
end if;
-- Subprogram body when N_Subprogram_Declaration =>
null;
when N_Subprogram_Body => when N_Entry_Body
if not Is_Generic_Subprogram (Defining_Entity (N)) then | N_Subprogram_Body
Traverse_Subprogram_Body (N, Process, Inside_Stubs); =>
end if; if not Is_Generic_Subprogram (Defining_Entity (N)) then
Traverse_Subprogram_Body (N, Process, Inside_Stubs);
end if;
when N_Subprogram_Body_Stub => when N_Subprogram_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) then
declare declare
Body_N : constant Node_Id := Get_Body_From_Stub (N); Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin begin
if Inside_Stubs if Inside_Stubs
and then and then
not Is_Generic_Subprogram (Defining_Entity (Body_N)) not Is_Generic_Subprogram (Defining_Entity (Body_N))
then then
Traverse_Subprogram_Body Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
(Body_N, Process, Inside_Stubs); end if;
end if; end;
end; end if;
end if;
-- Protected unit when N_Protected_Definition =>
Traverse_Declarations_Or_Statements
(Visible_Declarations (N), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (N), Process, Inside_Stubs);
when N_Protected_Definition => when N_Protected_Body =>
Traverse_Declarations_Or_Statements Traverse_Protected_Body (N, Process, Inside_Stubs);
(Visible_Declarations (N), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (N), Process, Inside_Stubs);
when N_Protected_Body => when N_Protected_Body_Stub =>
Traverse_Protected_Body (N, Process, Inside_Stubs); if Present (Library_Unit (N)) then
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
end if;
end;
end if;
when N_Protected_Body_Stub => when N_Task_Definition =>
if Present (Library_Unit (N)) then Traverse_Declarations_Or_Statements
declare (Visible_Declarations (N), Process, Inside_Stubs);
Body_N : constant Node_Id := Get_Body_From_Stub (N); Traverse_Declarations_Or_Statements
begin (Private_Declarations (N), Process, Inside_Stubs);
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
end if;
end;
end if;
-- Task unit when N_Task_Body =>
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_Task_Definition => when N_Task_Body_Stub =>
Traverse_Declarations_Or_Statements if Present (Library_Unit (N)) then
(Visible_Declarations (N), Process, Inside_Stubs); declare
Traverse_Declarations_Or_Statements Body_N : constant Node_Id := Get_Body_From_Stub (N);
(Private_Declarations (N), Process, Inside_Stubs); begin
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (Body_N), Process,
Inside_Stubs);
end if;
end;
end if;
when N_Task_Body => when N_Block_Statement =>
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs); (Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs); (Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_Task_Body_Stub => when N_If_Statement =>
if Present (Library_Unit (N)) then
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (Body_N), Process,
Inside_Stubs);
end if;
end;
end if;
-- Block statement -- Traverse the statements in the THEN part
when N_Block_Statement => Traverse_Declarations_Or_Statements
Traverse_Declarations_Or_Statements (Then_Statements (N), Process, Inside_Stubs);
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_If_Statement => -- Loop through ELSIF parts if present
-- Traverse the statements in the THEN part if Present (Elsif_Parts (N)) then
declare
Elif : Node_Id := First (Elsif_Parts (N));
Traverse_Declarations_Or_Statements begin
(Then_Statements (N), Process, Inside_Stubs); while Present (Elif) loop
Traverse_Declarations_Or_Statements
(Then_Statements (Elif), Process, Inside_Stubs);
Next (Elif);
end loop;
end;
end if;
-- Loop through ELSIF parts if present -- Finally traverse the ELSE statements if present
if Present (Elsif_Parts (N)) then Traverse_Declarations_Or_Statements
declare (Else_Statements (N), Process, Inside_Stubs);
Elif : Node_Id := First (Elsif_Parts (N));
begin when N_Case_Statement =>
while Present (Elif) loop
Traverse_Declarations_Or_Statements
(Then_Statements (Elif), Process, Inside_Stubs);
Next (Elif);
end loop;
end;
end if;
-- Finally traverse the ELSE statements if present -- Process case branches
Traverse_Declarations_Or_Statements declare
(Else_Statements (N), Process, Inside_Stubs); Alt : Node_Id;
begin
Alt := First (Alternatives (N));
while Present (Alt) loop
Traverse_Declarations_Or_Statements
(Statements (Alt), Process, Inside_Stubs);
Next (Alt);
end loop;
end;
-- Case statement when N_Extended_Return_Statement =>
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_Case_Statement => when N_Loop_Statement =>
Traverse_Declarations_Or_Statements
(Statements (N), Process, Inside_Stubs);
-- Process case branches -- Generic declarations are ignored
declare when others =>
Alt : Node_Id; null;
begin end case;
Alt := First (Alternatives (N)); end Traverse_Declaration_Or_Statement;
while Present (Alt) loop
Traverse_Declarations_Or_Statements
(Statements (Alt), Process, Inside_Stubs);
Next (Alt);
end loop;
end;
-- Extended return statement -----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
when N_Extended_Return_Statement => procedure Traverse_Declarations_Or_Statements
Traverse_Handled_Statement_Sequence (L : List_Id;
(Handled_Statement_Sequence (N), Process, Inside_Stubs); Process : Node_Processing;
Inside_Stubs : Boolean)
is
N : Node_Id;
-- Loop begin
-- Loop through statements or declarations
when N_Loop_Statement => N := First (L);
Traverse_Declarations_Or_Statements while Present (N) loop
(Statements (N), Process, Inside_Stubs); -- Call Process on all declarations
-- Generic declarations are ignored if Nkind (N) in N_Declaration
or else
Nkind (N) in N_Later_Decl_Item
then
Process (N);
end if;
when others => Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs);
null;
end case;
Next (N); Next (N);
end loop; end loop;
......
gcc/ada/sem_attr.adb
...@@ -7265,20 +7265,58 @@ package body Sem_Attr is ...@@ -7265,20 +7265,58 @@ package body Sem_Attr is
return; return;
end if; end if;
-- Special processing for cases where the prefix is an object. For -- Special processing for cases where the prefix is an object. For this
-- this purpose, a string literal counts as an object (attributes -- purpose, a string literal counts as an object (attributes of string
-- of string literals can only appear in generated code). -- literals can only appear in generated code).
if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then 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 -- For Component_Size, the prefix is an array object, and we apply
-- the attribute to the type of the object. This is allowed for -- the attribute to the type of the object. This is allowed for both
-- both unconstrained and constrained arrays, since the bounds -- unconstrained and constrained arrays, since the bounds have no
-- have no influence on the value of this attribute. -- influence on the value of this attribute.
if Id = Attribute_Component_Size then if Id = Attribute_Component_Size then
P_Entity := Etype (P); 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 -- 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 -- the attribute to the type of the array, but we need a constrained
-- type for this, so we use the actual subtype if available. -- type for this, so we use the actual subtype if available.
...@@ -7971,7 +8009,26 @@ package body Sem_Attr is ...@@ -7971,7 +8009,26 @@ package body Sem_Attr is
-- Enum_Rep -- -- 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 -- For an enumeration type with a non-standard representation use
-- the Enumeration_Rep field of the proper constant. Note that this -- the Enumeration_Rep field of the proper constant. Note that this
...@@ -7983,15 +8040,16 @@ package body Sem_Attr is ...@@ -7983,15 +8040,16 @@ package body Sem_Attr is
if Is_Enumeration_Type (P_Type) if Is_Enumeration_Type (P_Type)
and then Has_Non_Standard_Rep (P_Type) and then Has_Non_Standard_Rep (P_Type)
then 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 -- For enumeration types with standard representations and all other
-- other cases (i.e. all integer and modular types), Enum_Rep -- cases (i.e. all integer and modular types), Enum_Rep is equivalent
-- is equivalent to Pos. -- to Pos.
else else
Fold_Uint (N, Expr_Value (E1), Static); Fold_Uint (N, Expr_Value (Val), Static);
end if; end if;
end Enum_Rep;
-------------- --------------
-- Enum_Val -- -- Enum_Val --
......
gcc/ada/sem_prag.adb
...@@ -4833,6 +4833,12 @@ package body Sem_Prag is ...@@ -4833,6 +4833,12 @@ package body Sem_Prag is
elsif Is_Loop_Pragma (Stmt) then elsif Is_Loop_Pragma (Stmt) then
Prag := Stmt; 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 -- A non-pragma is separating the group from the
-- current pragma, the placement is illegal. -- current pragma, the placement is illegal.
......
gcc/ada/sem_util.adb
...@@ -11309,40 +11309,9 @@ package body Sem_Util is ...@@ -11309,40 +11309,9 @@ package body Sem_Util is
function Is_Descendant_Of_Suspension_Object function Is_Descendant_Of_Suspension_Object
(Typ : Entity_Id) return Boolean (Typ : Entity_Id) return Boolean
is 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; Cur_Typ : Entity_Id;
Par_Typ : Entity_Id; Par_Typ : Entity_Id;
-- Start of processing for Is_Descendant_Of_Suspension_Object
begin begin
-- Climb the type derivation chain checking each parent type against -- Climb the type derivation chain checking each parent type against
-- Suspension_Object. -- Suspension_Object.
...@@ -13161,6 +13130,28 @@ package body Sem_Util is ...@@ -13161,6 +13130,28 @@ package body Sem_Util is
and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
end Is_Subprogram_Stub_Without_Prior_Declaration; 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 -- -- Is_Synchronized_Tagged_Type --
--------------------------------- ---------------------------------
......
gcc/ada/sem_util.ads
...@@ -1503,6 +1503,10 @@ package Sem_Util is ...@@ -1503,6 +1503,10 @@ package Sem_Util is
-- Return True if N is a subprogram stub with no prior subprogram -- Return True if N is a subprogram stub with no prior subprogram
-- declaration. -- 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; 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)) -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2))
......
gcc/ada/spark_xrefs.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -111,9 +111,10 @@ package SPARK_Xrefs is ...@@ -111,9 +111,10 @@ package SPARK_Xrefs is
-- type is a single letter identifying the type of the entity, using -- type is a single letter identifying the type of the entity, using
-- the same code as in cross-references: -- the same code as in cross-references:
-- K = package -- K = package (k = generic package)
-- V = function -- V = function (v = generic function)
-- U = procedure -- U = procedure (u = generic procedure)
-- Y = entry
-- col is the column number of the scope entity -- 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