Skip to content

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

[multiple changes] 

2016-06-22  Hristian Kirtchev  <kirtchev@adacore.com>

	* lib-xref-spark_specific.adb, checks.adb, sem_ch13.adb: Minor
	reformatting.
	* exp_ch7.adb: Minor typo fix.
	* lib.ads (Get_Top_Level_Code_Unit): Add comment.

2016-06-22  Bob Duff  <duff@adacore.com>

	* s-tassta.adb (Task_Wrapper): Fix handling of Fall_Back_Handler
	wrt independent tasks.

2016-06-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_dim.adb (Analyze_Dimension): Propagate dimension for
	explicit_dereference nodes when they do not come from source,
	to handle correctly dimensional analysis on iterators over
	containers whose elements have declared dimensions.

From-SVN: r237691
parent 7ffbef99
Showing with 141 additions and 100 deletions
gcc/ada/ChangeLog
2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
* lib-xref-spark_specific.adb, checks.adb, sem_ch13.adb: Minor
reformatting.
* exp_ch7.adb: Minor typo fix.
* lib.ads (Get_Top_Level_Code_Unit): Add comment.
2016-06-22 Bob Duff <duff@adacore.com>
* s-tassta.adb (Task_Wrapper): Fix handling of Fall_Back_Handler
wrt independent tasks.
2016-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension): Propagate dimension for
explicit_dereference nodes when they do not come from source,
to handle correctly dimensional analysis on iterators over
containers whose elements have declared dimensions.
2016-06-22 Arnaud Charlet <charlet@adacore.com> 2016-06-22 Arnaud Charlet <charlet@adacore.com>
* spark_xrefs.ads (Scope_Num): type refined to positive integers. * spark_xrefs.ads (Scope_Num): type refined to positive integers.
......
gcc/ada/checks.adb
...@@ -644,8 +644,6 @@ package body Checks is ...@@ -644,8 +644,6 @@ package body Checks is
-- when Aexp is a reference to a constant, in which case Expr gets -- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant). -- reset to reference the value expression of the constant).
-- Start of processing for Apply_Address_Clause_Check
begin begin
-- See if alignment check needed. Note that we never need a check if the -- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed. -- maximum alignment is one, since the check will always succeed.
...@@ -679,8 +677,8 @@ package body Checks is ...@@ -679,8 +677,8 @@ package body Checks is
AL : Uint := Alignment (Typ); AL : Uint := Alignment (Typ);
begin begin
-- The object alignment might be more restrictive than the -- The object alignment might be more restrictive than the type
-- type alignment. -- alignment.
if Known_Alignment (E) then if Known_Alignment (E) then
AL := Alignment (E); AL := Alignment (E);
...@@ -718,9 +716,9 @@ package body Checks is ...@@ -718,9 +716,9 @@ package body Checks is
-- Generate a check to raise PE if alignment may be inappropriate -- Generate a check to raise PE if alignment may be inappropriate
else else
-- If the original expression is a non-static constant, use the -- If the original expression is a non-static constant, use the name
-- name of the constant itself rather than duplicating its -- of the constant itself rather than duplicating its initialization
-- defining expression, which was extracted above. -- expression, which was extracted above.
-- Note: Expr is empty if the address-clause is applied to in-mode -- Note: Expr is empty if the address-clause is applied to in-mode
-- actuals (allowed by 13.1(22)). -- actuals (allowed by 13.1(22)).
...@@ -729,8 +727,8 @@ package body Checks is ...@@ -729,8 +727,8 @@ package body Checks is
or else or else
(Is_Entity_Name (Expression (AC)) (Is_Entity_Name (Expression (AC))
and then Ekind (Entity (Expression (AC))) = E_Constant and then Ekind (Entity (Expression (AC))) = E_Constant
and then Nkind (Parent (Entity (Expression (AC)))) and then Nkind (Parent (Entity (Expression (AC)))) =
= N_Object_Declaration) N_Object_Declaration)
then then
Expr := New_Copy_Tree (Expression (AC)); Expr := New_Copy_Tree (Expression (AC));
else else
...@@ -765,6 +763,7 @@ package body Checks is ...@@ -765,6 +763,7 @@ package body Checks is
-- No_Exception_Propagation). -- No_Exception_Propagation).
if Warning_Msg /= No_Error_Msg then if Warning_Msg /= No_Error_Msg then
-- If the expression has a known at compile time value, then -- If the expression has a known at compile time value, then
-- once we know the alignment of the type, we can check if the -- once we know the alignment of the type, we can check if the
-- exception will be raised or not, and if not, we don't need -- exception will be raised or not, and if not, we don't need
...@@ -773,12 +772,13 @@ package body Checks is ...@@ -773,12 +772,13 @@ package body Checks is
if Compile_Time_Known_Value (Expr) then if Compile_Time_Known_Value (Expr) then
Alignment_Warnings.Append Alignment_Warnings.Append
((E => E, A => Expr_Value (Expr), W => Warning_Msg)); ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
else
-- Add explanation of the warning generated by the check -- Add explanation of the warning generated by the check
else
Error_Msg_N Error_Msg_N
("\address value may be incompatible with alignment " ("\address value may be incompatible with alignment of "
& "of object?X?", AC); & "object?X?", AC);
end if; end if;
end if; end if;
...@@ -786,6 +786,7 @@ package body Checks is ...@@ -786,6 +786,7 @@ package body Checks is
end if; end if;
exception exception
-- If we have some missing run time component in configurable run time -- If we have some missing run time component in configurable run time
-- mode then just skip the check (it is not required in any case). -- mode then just skip the check (it is not required in any case).
......
gcc/ada/exp_ch7.adb
...@@ -4616,7 +4616,7 @@ package body Exp_Ch7 is ...@@ -4616,7 +4616,7 @@ package body Exp_Ch7 is
Set_Ghost_Mode_From_Entity (Work_Typ); Set_Ghost_Mode_From_Entity (Work_Typ);
-- Emulate the environment of the invariant procedure by installing -- Emulate the environment of the invariant procedure by installing
-- its scope and formal parameters. Note that this is not need, but -- its scope and formal parameters. Note that this is not needed, but
-- having the scope of the invariant procedure installed helps with -- having the scope of the invariant procedure installed helps with
-- the detection of invariant-related errors. -- the detection of invariant-related errors.
......
gcc/ada/lib-xref-spark_specific.adb
...@@ -102,9 +102,9 @@ package body SPARK_Specific is ...@@ -102,9 +102,9 @@ package body SPARK_Specific is
generic generic
with procedure Process (N : Node_Id) is <>; with procedure Process (N : Node_Id) is <>;
procedure Traverse_Compilation_Unit (CU : Node_Id; Inside_Stubs : Boolean); procedure Traverse_Compilation_Unit (CU : Node_Id; Inside_Stubs : Boolean);
-- Call Process on all declarations in compilation unit CU. If -- Call Process on all declarations within compilation unit CU. If flag
-- Inside_Stubs is True, then the body of stubs is also traversed. -- Inside_Stubs is True, then the body of stubs is also traversed. Generic
-- Generic declarations are ignored. -- declarations are ignored.
-------------------- --------------------
-- Add_SPARK_File -- -- Add_SPARK_File --
...@@ -114,9 +114,6 @@ package body SPARK_Specific is ...@@ -114,9 +114,6 @@ package body SPARK_Specific is
File : constant Source_File_Index := Source_Index (Uspec); File : constant Source_File_Index := Source_Index (Uspec);
From : constant Scope_Index := SPARK_Scope_Table.Last + 1; From : constant Scope_Index := SPARK_Scope_Table.Last + 1;
File_Name : String_Ptr;
Unit_File_Name : String_Ptr;
Scope_Id : Pos := 1; Scope_Id : Pos := 1;
procedure Add_SPARK_Scope (N : Node_Id); procedure Add_SPARK_Scope (N : Node_Id);
...@@ -147,25 +144,23 @@ package body SPARK_Specific is ...@@ -147,25 +144,23 @@ package body SPARK_Specific is
end if; end if;
case Ekind (E) is case Ekind (E) is
when E_Entry when E_Entry |
| E_Entry_Family E_Entry_Family |
| E_Generic_Function E_Generic_Function |
| E_Generic_Package E_Generic_Package |
| E_Generic_Procedure E_Generic_Procedure |
| E_Package E_Package |
| E_Protected_Type E_Protected_Type |
| E_Task_Type E_Task_Type =>
=>
Typ := Xref_Entity_Letters (Ekind (E)); Typ := Xref_Entity_Letters (Ekind (E));
when E_Function when E_Function | E_Procedure =>
| E_Procedure
=>
-- In SPARK we need to distinguish protected functions and -- In SPARK we need to distinguish protected functions and
-- procedures from ordinary subprograms, but there are no special -- procedures from ordinary subprograms, but there are no
-- Xref letters for them. Since this distiction is only needed to -- special Xref letters for them. Since this distiction is
-- detect protected calls, we pretend that such calls are entry -- only needed to detect protected calls, we pretend that
-- calls. -- such calls are entry calls.
if Ekind (Scope (E)) = E_Protected_Type then if Ekind (Scope (E)) = E_Protected_Type then
Typ := Xref_Entity_Letters (E_Entry); Typ := Xref_Entity_Letters (E_Entry);
...@@ -173,11 +168,10 @@ package body SPARK_Specific is ...@@ -173,11 +168,10 @@ package body SPARK_Specific is
Typ := Xref_Entity_Letters (Ekind (E)); Typ := Xref_Entity_Letters (Ekind (E));
end if; end if;
when E_Package_Body when E_Package_Body |
| E_Protected_Body E_Protected_Body |
| E_Subprogram_Body E_Subprogram_Body |
| E_Task_Body E_Task_Body =>
=>
Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
when E_Void => when E_Void =>
...@@ -218,22 +212,30 @@ package body SPARK_Specific is ...@@ -218,22 +212,30 @@ 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_Entry_Body, -- entries -- Entries
N_Entry_Declaration)
or else if Nkind_In (N, N_Entry_Body, N_Entry_Declaration)
Nkind_In (N, N_Package_Body, -- packages
-- Packages
or else Nkind_In (N, N_Package_Body,
N_Package_Body_Stub, N_Package_Body_Stub,
N_Package_Declaration) N_Package_Declaration)
or else -- Protected units
Nkind_In (N, N_Protected_Body, -- protected objects
or else Nkind_In (N, N_Protected_Body,
N_Protected_Body_Stub, N_Protected_Body_Stub,
N_Protected_Type_Declaration) N_Protected_Type_Declaration)
or else
Nkind_In (N, N_Subprogram_Body, -- subprograms -- Subprograms
or else Nkind_In (N, N_Subprogram_Body,
N_Subprogram_Body_Stub, N_Subprogram_Body_Stub,
N_Subprogram_Declaration) N_Subprogram_Declaration)
or else
Nkind_In (N, N_Task_Body, -- tasks -- Task units
or else Nkind_In (N, N_Task_Body,
N_Task_Body_Stub, N_Task_Body_Stub,
N_Task_Type_Declaration) N_Task_Type_Declaration)
then then
...@@ -244,6 +246,11 @@ package body SPARK_Specific is ...@@ -244,6 +246,11 @@ package body SPARK_Specific is
procedure Traverse_Scopes is new procedure Traverse_Scopes is new
Traverse_Compilation_Unit (Detect_And_Add_SPARK_Scope); Traverse_Compilation_Unit (Detect_And_Add_SPARK_Scope);
-- Local variables
File_Name : String_Ptr;
Unit_File_Name : String_Ptr;
-- Start of processing for Add_SPARK_File -- Start of processing for Add_SPARK_File
begin begin
...@@ -307,6 +314,9 @@ package body SPARK_Specific is ...@@ -307,6 +314,9 @@ package body SPARK_Specific is
function Get_Entity_Type (E : Entity_Id) return Character; function Get_Entity_Type (E : Entity_Id) return Character;
-- Return a character representing the type of entity -- Return a character representing the type of entity
function Get_Scope_Num (N : Entity_Id) return Nat;
-- Return the scope number associated to entity N
function Is_Constant_Object_Without_Variable_Input function Is_Constant_Object_Without_Variable_Input
(E : Entity_Id) return Boolean; (E : Entity_Id) return Boolean;
-- Return True if E is known to have no variable input, as defined in -- Return True if E is known to have no variable input, as defined in
...@@ -333,6 +343,9 @@ package body SPARK_Specific is ...@@ -333,6 +343,9 @@ package body SPARK_Specific is
procedure Move (From : Natural; To : Natural); procedure Move (From : Natural; To : Natural);
-- Move procedure for Sort call -- Move procedure for Sort call
procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
-- Associate entity N to scope number Num
procedure Update_Scope_Range procedure Update_Scope_Range
(S : Scope_Index; (S : Scope_Index;
From : Xref_Index; From : Xref_Index;
...@@ -341,12 +354,6 @@ package body SPARK_Specific is ...@@ -341,12 +354,6 @@ package body SPARK_Specific is
package Sorting is new GNAT.Heap_Sort_G (Move, Lt); package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
function Get_Scope_Num (N : Entity_Id) return Nat;
-- Return the scope number associated to entity N
procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
-- Associate entity N to scope number Num
No_Scope : constant Nat := 0; No_Scope : constant Nat := 0;
-- Initial scope counter -- Initial scope counter
...@@ -551,7 +558,7 @@ package body SPARK_Specific is ...@@ -551,7 +558,7 @@ package body SPARK_Specific is
-- Lt -- -- Lt --
-------- --------
function Lt (Op1, Op2 : Natural) return Boolean is function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1))); T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));
T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2))); T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
...@@ -767,9 +774,7 @@ package body SPARK_Specific is ...@@ -767,9 +774,7 @@ package body SPARK_Specific is
Nrefs := 1; Nrefs := 1;
for Index in 2 .. Ref_Count loop for Index in 2 .. Ref_Count loop
if Xrefs.Table (Rnums (Index)) /= if Xrefs.Table (Rnums (Index)) /= Xrefs.Table (Rnums (Nrefs)) then
Xrefs.Table (Rnums (Nrefs))
then
Nrefs := Nrefs + 1; Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (Index); Rnums (Nrefs) := Rnums (Index);
end if; end if;
...@@ -900,7 +905,8 @@ package body SPARK_Specific is ...@@ -900,7 +905,8 @@ package body SPARK_Specific is
(Sdep_Table : Unit_Ref_Table; (Sdep_Table : Unit_Ref_Table;
Num_Sdep : Nat) Num_Sdep : Nat)
is is
Sdep, Sdep_Next : Pos; Sdep : Pos;
Sdep_Next : Pos;
-- Index of the current and next source dependency -- Index of the current and next source dependency
Sdep_File : Pos; Sdep_File : Pos;
...@@ -908,7 +914,8 @@ package body SPARK_Specific is ...@@ -908,7 +914,8 @@ package body SPARK_Specific is
-- library-level instances of generic units this points to the unit -- library-level instances of generic units this points to the unit
-- of the body, because this is where references are assigned to. -- of the body, because this is where references are assigned to.
Uspec, Ubody : Unit_Number_Type; Ubody : Unit_Number_Type;
Uspec : Unit_Number_Type;
-- Unit numbers for the dependency spec and possibly its body (only in -- Unit numbers for the dependency spec and possibly its body (only in
-- the case of library-level instance of a generic package). -- the case of library-level instance of a generic package).
...@@ -936,20 +943,22 @@ package body SPARK_Specific is ...@@ -936,20 +943,22 @@ package body SPARK_Specific is
declare declare
Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep)); Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep));
Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1)); Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1));
begin begin
-- Both Cunit point to compilation unit nodes -- Both Cunit point to compilation unit nodes
pragma Assert (Nkind (Cunit1) = N_Compilation_Unit
and then pragma Assert
Nkind (Cunit2) = N_Compilation_Unit); (Nkind (Cunit1) = N_Compilation_Unit
and then Nkind (Cunit2) = N_Compilation_Unit);
-- Do not depend on the sorting order, which is based on -- Do not depend on the sorting order, which is based on
-- Unit_Name and for library-level instances of nested -- Unit_Name and for library-level instances of nested
-- generic-packages they are equal. -- generic-packages they are equal.
-- If declaration comes before the body -- If declaration comes before the body
if Nkind (Unit (Cunit1)) = N_Package_Declaration if Nkind (Unit (Cunit1)) = N_Package_Declaration
and then and then Nkind (Unit (Cunit2)) = N_Package_Body
Nkind (Unit (Cunit2)) = N_Package_Body
then then
Uspec := Sdep_Table (Sdep); Uspec := Sdep_Table (Sdep);
Ubody := Sdep_Table (Sdep + 1); Ubody := Sdep_Table (Sdep + 1);
...@@ -959,8 +968,7 @@ package body SPARK_Specific is ...@@ -959,8 +968,7 @@ package body SPARK_Specific is
-- If body comes before declaration -- If body comes before declaration
elsif Nkind (Unit (Cunit1)) = N_Package_Body elsif Nkind (Unit (Cunit1)) = N_Package_Body
and then and then Nkind (Unit (Cunit2)) = N_Package_Declaration
Nkind (Unit (Cunit2)) = N_Package_Declaration
then then
Uspec := Sdep_Table (Sdep + 1); Uspec := Sdep_Table (Sdep + 1);
Ubody := Sdep_Table (Sdep); Ubody := Sdep_Table (Sdep);
...@@ -970,18 +978,19 @@ package body SPARK_Specific is ...@@ -970,18 +978,19 @@ package body SPARK_Specific is
-- Otherwise it is an error -- Otherwise it is an error
else else
raise Program_Error; raise Program_Error;
end if; end if;
Sdep_Next := Sdep + 2; Sdep_Next := Sdep + 2;
end; end;
-- ??? otherwise?
else else
Uspec := Sdep_Table (Sdep); Uspec := Sdep_Table (Sdep);
Ubody := No_Unit; Ubody := No_Unit;
Sdep_File := Sdep; Sdep_File := Sdep;
Sdep_Next := Sdep + 1; Sdep_Next := Sdep + 1;
end if; end if;
...@@ -1191,7 +1200,6 @@ package body SPARK_Specific is ...@@ -1191,7 +1200,6 @@ package body SPARK_Specific is
-- Start of processing for Generate_Dereference -- Start of processing for Generate_Dereference
begin begin
if Loc > No_Location then if Loc > No_Location then
Drefs.Increment_Last; Drefs.Increment_Last;
...@@ -1234,11 +1242,9 @@ package body SPARK_Specific is ...@@ -1234,11 +1242,9 @@ package body SPARK_Specific is
(CU : Node_Id; (CU : Node_Id;
Inside_Stubs : Boolean) Inside_Stubs : Boolean)
is is
Lu : Node_Id;
procedure Traverse_Block (N : Node_Id); procedure Traverse_Block (N : Node_Id);
procedure Traverse_Declarations_And_HSS (N : Node_Id);
procedure Traverse_Declaration_Or_Statement (N : Node_Id); procedure Traverse_Declaration_Or_Statement (N : Node_Id);
procedure Traverse_Declarations_And_HSS (N : Node_Id);
procedure Traverse_Declarations_Or_Statements (L : List_Id); procedure Traverse_Declarations_Or_Statements (L : List_Id);
procedure Traverse_Handled_Statement_Sequence (N : Node_Id); procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id); procedure Traverse_Package_Body (N : Node_Id);
...@@ -1260,8 +1266,7 @@ package body SPARK_Specific is ...@@ -1260,8 +1266,7 @@ package body SPARK_Specific is
-- Traverse_Declaration_Or_Statement -- -- Traverse_Declaration_Or_Statement --
--------------------------------------- ---------------------------------------
procedure Traverse_Declaration_Or_Statement (N : Node_Id) procedure Traverse_Declaration_Or_Statement (N : Node_Id) is
is
begin begin
case Nkind (N) is case Nkind (N) is
when N_Package_Declaration => when N_Package_Declaration =>
...@@ -1278,8 +1283,8 @@ package body SPARK_Specific is ...@@ -1278,8 +1283,8 @@ package body SPARK_Specific is
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 Ekind (Defining_Entity (Body_N)) /=
Ekind (Defining_Entity (Body_N)) /= E_Generic_Package E_Generic_Package
then then
Traverse_Package_Body (Body_N); Traverse_Package_Body (Body_N);
end if; end if;
...@@ -1312,13 +1317,12 @@ package body SPARK_Specific is ...@@ -1312,13 +1317,12 @@ package body SPARK_Specific is
Traverse_Protected_Body (N); Traverse_Protected_Body (N);
when N_Protected_Body_Stub => when N_Protected_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) and then Inside_Stubs then
if Inside_Stubs then
Traverse_Protected_Body (Get_Body_From_Stub (N)); Traverse_Protected_Body (Get_Body_From_Stub (N));
end if; end if;
end if;
when N_Protected_Type_Declaration | N_Single_Protected_Declaration => when N_Protected_Type_Declaration |
N_Single_Protected_Declaration =>
Traverse_Visible_And_Private_Parts (Protected_Definition (N)); Traverse_Visible_And_Private_Parts (Protected_Definition (N));
when N_Task_Definition => when N_Task_Definition =>
...@@ -1328,11 +1332,9 @@ package body SPARK_Specific is ...@@ -1328,11 +1332,9 @@ package body SPARK_Specific is
Traverse_Task_Body (N); Traverse_Task_Body (N);
when N_Task_Body_Stub => when N_Task_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) and then Inside_Stubs then
if Inside_Stubs then
Traverse_Task_Body (Get_Body_From_Stub (N)); Traverse_Task_Body (Get_Body_From_Stub (N));
end if; end if;
end if;
when N_Block_Statement => when N_Block_Statement =>
Traverse_Block (N); Traverse_Block (N);
...@@ -1394,8 +1396,7 @@ package body SPARK_Specific is ...@@ -1394,8 +1396,7 @@ package body SPARK_Specific is
-- Traverse_Declarations_And_HSS -- -- Traverse_Declarations_And_HSS --
----------------------------------- -----------------------------------
procedure Traverse_Declarations_And_HSS (N : Node_Id) procedure Traverse_Declarations_And_HSS (N : Node_Id) is
is
begin begin
Traverse_Declarations_Or_Statements (Declarations (N)); Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
...@@ -1405,8 +1406,7 @@ package body SPARK_Specific is ...@@ -1405,8 +1406,7 @@ package body SPARK_Specific is
-- Traverse_Declarations_Or_Statements -- -- Traverse_Declarations_Or_Statements --
----------------------------------------- -----------------------------------------
procedure Traverse_Declarations_Or_Statements (L : List_Id) procedure Traverse_Declarations_Or_Statements (L : List_Id) is
is
N : Node_Id; N : Node_Id;
begin begin
...@@ -1414,13 +1414,12 @@ package body SPARK_Specific is ...@@ -1414,13 +1414,12 @@ package body SPARK_Specific is
N := First (L); N := First (L);
while Present (N) loop while Present (N) loop
-- Call Process on all declarations -- Call Process on all declarations
if Nkind (N) in N_Declaration if Nkind (N) in N_Declaration
or else or else Nkind (N) in N_Later_Decl_Item
Nkind (N) in N_Later_Decl_Item or else Nkind (N) = N_Entry_Body
or else
Nkind (N) = N_Entry_Body
then then
Process (N); Process (N);
end if; end if;
...@@ -1435,8 +1434,7 @@ package body SPARK_Specific is ...@@ -1435,8 +1434,7 @@ package body SPARK_Specific is
-- Traverse_Handled_Statement_Sequence -- -- Traverse_Handled_Statement_Sequence --
----------------------------------------- -----------------------------------------
procedure Traverse_Handled_Statement_Sequence (N : Node_Id) procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
is
Handler : Node_Id; Handler : Node_Id;
begin begin
...@@ -1483,12 +1481,20 @@ package body SPARK_Specific is ...@@ -1483,12 +1481,20 @@ package body SPARK_Specific is
procedure Traverse_Task_Body (N : Node_Id) renames procedure Traverse_Task_Body (N : Node_Id) renames
Traverse_Declarations_And_HSS; Traverse_Declarations_And_HSS;
----------------------------------------
-- Traverse_Visible_And_Private_Parts --
----------------------------------------
procedure Traverse_Visible_And_Private_Parts (N : Node_Id) is procedure Traverse_Visible_And_Private_Parts (N : Node_Id) is
begin begin
Traverse_Declarations_Or_Statements (Visible_Declarations (N)); Traverse_Declarations_Or_Statements (Visible_Declarations (N));
Traverse_Declarations_Or_Statements (Private_Declarations (N)); Traverse_Declarations_Or_Statements (Private_Declarations (N));
end Traverse_Visible_And_Private_Parts; end Traverse_Visible_And_Private_Parts;
-- Local variables
Lu : Node_Id;
-- Start of processing for Traverse_Compilation_Unit -- Start of processing for Traverse_Compilation_Unit
begin begin
......
gcc/ada/lib.ads
...@@ -548,6 +548,12 @@ package Lib is ...@@ -548,6 +548,12 @@ package Lib is
-- This is like Get_Code_Unit, except that in the case of subunits, it -- This is like Get_Code_Unit, except that in the case of subunits, it
-- returns the top-level unit to which the subunit belongs instead of -- returns the top-level unit to which the subunit belongs instead of
-- the subunit. -- the subunit.
--
-- Note: for nodes and slocs in declarations of library-level instances of
-- generics these routines wrongly return the unit number corresponding to
-- the body of the instance. In effect, locations of SPARK references in
-- ALI files are bogus. However, fixing this is not worth the effort, since
-- these references are only used for debugging.
function In_Extended_Main_Code_Unit function In_Extended_Main_Code_Unit
(N : Node_Or_Entity_Id) return Boolean; (N : Node_Or_Entity_Id) return Boolean;
......
gcc/ada/s-tassta.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL 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- --
...@@ -1339,7 +1339,13 @@ package body System.Tasking.Stages is ...@@ -1339,7 +1339,13 @@ package body System.Tasking.Stages is
if Self_ID.Common.Specific_Handler /= null then if Self_ID.Common.Specific_Handler /= null then
TH := Self_ID.Common.Specific_Handler; TH := Self_ID.Common.Specific_Handler;
else
-- Independent tasks should not call the Fall_Back_Handler (of the
-- environment task), because they are implementation artifacts that
-- should be invisible to Ada programs.
elsif Self_ID.Master_of_Task /= Independent_Task_Level then
-- Look for a fall-back handler following the master relationship -- Look for a fall-back handler following the master relationship
-- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
-- handler applies only to the dependent tasks of the task". Hence, -- handler applies only to the dependent tasks of the task". Hence,
......
gcc/ada/sem_dim.adb
...@@ -1121,13 +1121,15 @@ package body Sem_Dim is ...@@ -1121,13 +1121,15 @@ package body Sem_Dim is
begin begin
-- Aspect is an Ada 2012 feature. Note that there is no need to check -- Aspect is an Ada 2012 feature. Note that there is no need to check
-- dimensions for nodes that don't come from source, except for subtype -- dimensions for nodes that don't come from source, except for subtype
-- declarations where the dimensions are inherited from the base type. -- declarations where the dimensions are inherited from the base type,
-- and for explicit dereferences generated when expanding iterators.
if Ada_Version < Ada_2012 then if Ada_Version < Ada_2012 then
return; return;
elsif not Comes_From_Source (N) elsif not Comes_From_Source (N)
and then Nkind (N) /= N_Subtype_Declaration and then Nkind (N) /= N_Subtype_Declaration
and then Nkind (N) /= N_Explicit_Dereference
then then
return; return;
end if; end if;
...@@ -2015,7 +2017,8 @@ package body Sem_Dim is ...@@ -2015,7 +2017,8 @@ package body Sem_Dim is
end if; end if;
end if; end if;
-- Removal of dimensions in expression -- Remove dimensions from inner expressions, to prevent dimensions
-- table from growing uselessly.
case Nkind (N) is case Nkind (N) is
when N_Attribute_Reference | when N_Attribute_Reference |
......
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