Skip to content

R
riscv-gcc-1
Commit 009c0268 by Arnaud Charlet
Options

[multiple changes] 

2016-04-19  Olivier Hainque  <hainque@adacore.com>

	* par_sco.adb (Traverse_One, case N_Case_Statement):
	Skip pragmas before the first alternative.
	(Traverse_Handled_Statement_Sequence, Exception_Handlers): Likewise.

2016-04-19  Tristan Gingold  <gingold@adacore.com>

	* adaint.c (__gnat_lwp_self): New function (for darwin).
	* s-osinte-darwin.ads, s-osinte-darwin.adb (lwp_self): Import
	of __gnat_lwp_self.

From-SVN: r235204
parent 65f52ee9
Showing with 452 additions and 402 deletions
gcc/ada/ChangeLog
2016-04-19 Olivier Hainque <hainque@adacore.com> 2016-04-19 Olivier Hainque <hainque@adacore.com>
* par_sco.adb (Traverse_One, case N_Case_Statement):
Skip pragmas before the first alternative.
(Traverse_Handled_Statement_Sequence, Exception_Handlers): Likewise.
2016-04-19 Tristan Gingold <gingold@adacore.com>
* adaint.c (__gnat_lwp_self): New function (for darwin).
* s-osinte-darwin.ads, s-osinte-darwin.adb (lwp_self): Import
of __gnat_lwp_self.
2016-04-19 Olivier Hainque <hainque@adacore.com>
* sem_util.adb (Build_Elaboration_Entity): Always request an * sem_util.adb (Build_Elaboration_Entity): Always request an
elab counter when preserving control-flow. elab counter when preserving control-flow.
......
gcc/ada/adaint.c
...@@ -3101,6 +3101,30 @@ __gnat_lwp_self (void) ...@@ -3101,6 +3101,30 @@ __gnat_lwp_self (void)
} }
#endif #endif
#if defined (__APPLE__)
#include <mach/thread_info.h>
#include <mach/mach_init.h>
#include <mach/thread_act.h>
/* System-wide thread identifier. Note it could be truncated on 32 bit
hosts.
Previously was: pthread_mach_thread_np (pthread_self ()). */
void *
__gnat_lwp_self (void)
{
thread_identifier_info_data_t data;
mach_msg_type_number_t count = THREAD_IDENTIFIER_INFO_COUNT;
kern_return_t kret;
kret = thread_info (mach_thread_self (), THREAD_IDENTIFIER_INFO,
(thread_info_t) &data, &count);
if (kret == KERN_SUCCESS)
return (void *)(uintptr_t)data.thread_id;
else
return 0;
}
#endif
#if defined (__linux__) #if defined (__linux__)
#include <sched.h> #include <sched.h>
......
gcc/ada/par_sco.adb
...@@ -76,12 +76,12 @@ package body Par_SCO is ...@@ -76,12 +76,12 @@ package body Par_SCO is
-- running some steps multiple times (the second pass has to be started -- running some steps multiple times (the second pass has to be started
-- from multiple places). -- from multiple places).
package SCO_Raw_Table is new GNAT.Table ( package SCO_Raw_Table is new GNAT.Table
Table_Component_Type => SCO_Table_Entry, (Table_Component_Type => SCO_Table_Entry,
Table_Index_Type => Nat, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 500, Table_Initial => 500,
Table_Increment => 300); Table_Increment => 300);
----------------------- -----------------------
-- Unit Number Table -- -- Unit Number Table --
...@@ -95,13 +95,13 @@ package body Par_SCO is ...@@ -95,13 +95,13 @@ package body Par_SCO is
-- Note that the zero'th entry is here for convenience in sorting the -- Note that the zero'th entry is here for convenience in sorting the
-- table, the real lower bound is 1. -- table, the real lower bound is 1.
package SCO_Unit_Number_Table is new Table.Table ( package SCO_Unit_Number_Table is new Table.Table
Table_Component_Type => Unit_Number_Type, (Table_Component_Type => Unit_Number_Type,
Table_Index_Type => SCO_Unit_Index, Table_Index_Type => SCO_Unit_Index,
Table_Low_Bound => 0, -- see note above on sort Table_Low_Bound => 0, -- see note above on sort
Table_Initial => 20, Table_Initial => 20,
Table_Increment => 200, Table_Increment => 200,
Table_Name => "SCO_Unit_Number_Entry"); Table_Name => "SCO_Unit_Number_Entry");
------------------------------------------ ------------------------------------------
-- Condition/Operator/Pragma Hash Table -- -- Condition/Operator/Pragma Hash Table --
...@@ -120,10 +120,10 @@ package body Par_SCO is ...@@ -120,10 +120,10 @@ package body Par_SCO is
function Hash (F : Source_Ptr) return Header_Num; function Hash (F : Source_Ptr) return Header_Num;
-- Function to Hash source pointer value -- Function to Hash source pointer value
function Equal (F1, F2 : Source_Ptr) return Boolean; function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean;
-- Function to test two keys for equality -- Function to test two keys for equality
function "<" (S1, S2 : Source_Location) return Boolean; function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean;
-- Function to test for source locations order -- Function to test for source locations order
package SCO_Raw_Hash_Table is new Simple_HTable package SCO_Raw_Hash_Table is new Simple_HTable
...@@ -199,8 +199,8 @@ package body Par_SCO is ...@@ -199,8 +199,8 @@ package body Par_SCO is
(L : List_Id; (L : List_Id;
D : Dominant_Info := No_Dominant; D : Dominant_Info := No_Dominant;
P : Node_Id := Empty); P : Node_Id := Empty);
-- Process L, a list of statements or declarations dominated by D. -- Process L, a list of statements or declarations dominated by D. If P is
-- If P is present, it is processed as though it had been prepended to L. -- present, it is processed as though it had been prepended to L.
function Traverse_Declarations_Or_Statements function Traverse_Declarations_Or_Statements
(L : List_Id; (L : List_Id;
...@@ -218,20 +218,31 @@ package body Par_SCO is ...@@ -218,20 +218,31 @@ package body Par_SCO is
-- the others are not??? -- the others are not???
procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id);
procedure Traverse_Handled_Statement_Sequence procedure Traverse_Handled_Statement_Sequence
(N : Node_Id; (N : Node_Id;
D : Dominant_Info := No_Dominant); D : Dominant_Info := No_Dominant);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Declaration procedure Traverse_Package_Declaration
(N : Node_Id; (N : Node_Id;
D : Dominant_Info := No_Dominant); D : Dominant_Info := No_Dominant);
procedure Traverse_Subprogram_Or_Task_Body procedure Traverse_Subprogram_Or_Task_Body
(N : Node_Id; (N : Node_Id;
D : Dominant_Info := No_Dominant); D : Dominant_Info := No_Dominant);
procedure Traverse_Sync_Definition (N : Node_Id); procedure Traverse_Sync_Definition (N : Node_Id);
-- Traverse a protected definition or task definition -- Traverse a protected definition or task definition
-- Note regarding traversals: In a few cases where an Alternatives list is
-- involved, pragmas such as "pragma Page" may show up before the first
-- alternative. We skip them because we're out of statement or declaration
-- context, so these can't be pragmas of interest for SCO purposes, and
-- the regular alternative processing typically involves attribute queries
-- which aren't valid for a pragma.
procedure Write_SCOs_To_ALI_File is new Put_SCOs; procedure Write_SCOs_To_ALI_File is new Put_SCOs;
-- Write SCO information to the ALI file using routines in Lib.Util -- Write SCO information to the ALI file using routines in Lib.Util
...@@ -366,7 +377,7 @@ package body Par_SCO is ...@@ -366,7 +377,7 @@ package body Par_SCO is
-- Equal -- -- Equal --
----------- -----------
function Equal (F1, F2 : Source_Ptr) return Boolean is function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is
begin begin
return F1 = F2; return F1 = F2;
end Equal; end Equal;
...@@ -375,7 +386,7 @@ package body Par_SCO is ...@@ -375,7 +386,7 @@ package body Par_SCO is
-- < -- -- < --
------- -------
function "<" (S1, S2 : Source_Location) return Boolean is function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean is
begin begin
return S1.Line < S2.Line return S1.Line < S2.Line
or else (S1.Line = S2.Line and then S1.Col < S2.Col); or else (S1.Line = S2.Line and then S1.Col < S2.Col);
...@@ -386,10 +397,9 @@ package body Par_SCO is ...@@ -386,10 +397,9 @@ package body Par_SCO is
------------------ ------------------
function Has_Decision (N : Node_Id) return Boolean is function Has_Decision (N : Node_Id) return Boolean is
function Check_Node (N : Node_Id) return Traverse_Result; function Check_Node (N : Node_Id) return Traverse_Result;
-- Determine if Nkind (N) indicates the presence of a decision (i.e. -- Determine if Nkind (N) indicates the presence of a decision (i.e. N
-- N is a logical operator, which is a decision in itself, or an -- is a logical operator, which is a decision in itself, or an
-- IF-expression whose Condition attribute is a decision). -- IF-expression whose Condition attribute is a decision).
---------------- ----------------
...@@ -404,7 +414,7 @@ package body Par_SCO is ...@@ -404,7 +414,7 @@ package body Par_SCO is
-- needed in the secord pass. -- needed in the secord pass.
if Is_Logical_Operator (N) /= False if Is_Logical_Operator (N) /= False
or else Nkind (N) = N_If_Expression or else Nkind (N) = N_If_Expression
then then
return Abandon; return Abandon;
else else
...@@ -449,7 +459,7 @@ package body Par_SCO is ...@@ -449,7 +459,7 @@ package body Par_SCO is
function Is_Logical_Operator (N : Node_Id) return Tristate is function Is_Logical_Operator (N : Node_Id) return Tristate is
begin begin
if Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else) then if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then
return True; return True;
elsif Nkind_In (N, N_Op_And, N_Op_Or) then elsif Nkind_In (N, N_Op_And, N_Op_Or) then
return Unknown; return Unknown;
...@@ -470,6 +480,7 @@ package body Par_SCO is ...@@ -470,6 +480,7 @@ package body Par_SCO is
Pragma_Sloc : Source_Ptr) Pragma_Sloc : Source_Ptr)
is is
N : Node_Id; N : Node_Id;
begin begin
if L /= No_List then if L /= No_List then
N := First (L); N := First (L);
...@@ -511,13 +522,13 @@ package body Par_SCO is ...@@ -511,13 +522,13 @@ package body Par_SCO is
-- This data structure holds the conditions/pragmas to register in -- This data structure holds the conditions/pragmas to register in
-- SCO_Raw_Hash_Table. -- SCO_Raw_Hash_Table.
package Hash_Entries is new Table.Table ( package Hash_Entries is new Table.Table
Table_Component_Type => Hash_Entry, (Table_Component_Type => Hash_Entry,
Table_Index_Type => Nat, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 10, Table_Initial => 10,
Table_Increment => 10, Table_Increment => 10,
Table_Name => "Hash_Entries"); Table_Name => "Hash_Entries");
-- Hold temporarily (i.e. free'd before returning) the Hash_Entry before -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
-- they are registered in SCO_Raw_Hash_Table. -- they are registered in SCO_Raw_Hash_Table.
...@@ -527,10 +538,6 @@ package body Par_SCO is ...@@ -527,10 +538,6 @@ package body Par_SCO is
-- The flag will be set False if T is other than X, or if an operator -- The flag will be set False if T is other than X, or if an operator
-- other than NOT is in the sequence. -- other than NOT is in the sequence.
function Process_Node (N : Node_Id) return Traverse_Result;
-- Processes one node in the traversal, looking for logical operators,
-- and if one is found, outputs the appropriate table entries.
procedure Output_Decision_Operand (N : Node_Id); procedure Output_Decision_Operand (N : Node_Id);
-- The node N is the top level logical operator of a decision, or it is -- The node N is the top level logical operator of a decision, or it is
-- one of the operands of a logical operator belonging to a single -- one of the operands of a logical operator belonging to a single
...@@ -556,19 +563,24 @@ package body Par_SCO is ...@@ -556,19 +563,24 @@ package body Par_SCO is
-- the complex decision. It process the suboperands of the decision -- the complex decision. It process the suboperands of the decision
-- looking for nested decisions. -- looking for nested decisions.
function Process_Node (N : Node_Id) return Traverse_Result;
-- Processes one node in the traversal, looking for logical operators,
-- and if one is found, outputs the appropriate table entries.
----------------------------- -----------------------------
-- Output_Decision_Operand -- -- Output_Decision_Operand --
----------------------------- -----------------------------
procedure Output_Decision_Operand (N : Node_Id) is procedure Output_Decision_Operand (N : Node_Id) is
C1, C2 : Character; C1 : Character;
C2 : Character;
-- C1 holds a character that identifies the operation while C2 -- C1 holds a character that identifies the operation while C2
-- indicates whether we are sure (' ') or not ('?') this operation -- indicates whether we are sure (' ') or not ('?') this operation
-- belongs to the decision. '?' entries will be filtered out in the -- belongs to the decision. '?' entries will be filtered out in the
-- second (SCO_Record_Filtered) pass. -- second (SCO_Record_Filtered) pass.
L : Node_Id; L : Node_Id;
T : Tristate; T : Tristate;
begin begin
if No (N) then if No (N) then
...@@ -761,7 +773,7 @@ package body Par_SCO is ...@@ -761,7 +773,7 @@ package body Par_SCO is
-- Output header for sequence -- Output header for sequence
X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
Mark := SCO_Raw_Table.Last; Mark := SCO_Raw_Table.Last;
Mark_Hash := Hash_Entries.Last; Mark_Hash := Hash_Entries.Last;
Output_Header (T); Output_Header (T);
...@@ -804,6 +816,7 @@ package body Par_SCO is ...@@ -804,6 +816,7 @@ package body Par_SCO is
Cond : constant Node_Id := First (Expressions (N)); Cond : constant Node_Id := First (Expressions (N));
Thnx : constant Node_Id := Next (Cond); Thnx : constant Node_Id := Next (Cond);
Elsx : constant Node_Id := Next (Thnx); Elsx : constant Node_Id := Next (Thnx);
begin begin
Process_Decisions (Cond, 'I', Pragma_Sloc); Process_Decisions (Cond, 'I', Pragma_Sloc);
Process_Decisions (Thnx, 'X', Pragma_Sloc); Process_Decisions (Thnx, 'X', Pragma_Sloc);
...@@ -865,7 +878,6 @@ package body Par_SCO is ...@@ -865,7 +878,6 @@ package body Par_SCO is
----------- -----------
procedure pscos is procedure pscos is
procedure Write_Info_Char (C : Character) renames Write_Char; procedure Write_Info_Char (C : Character) renames Write_Char;
-- Write one character; -- Write one character;
...@@ -907,6 +919,7 @@ package body Par_SCO is ...@@ -907,6 +919,7 @@ package body Par_SCO is
((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)), ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
Inst_Loc => To_Source_Location (Inst_Sloc), Inst_Loc => To_Source_Location (Inst_Sloc),
Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src)))); Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
pragma Assert pragma Assert
(SCO_Instance_Table.Last = SCO_Instance_Index (Id)); (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
end Record_Instance; end Record_Instance;
...@@ -918,6 +931,7 @@ package body Par_SCO is ...@@ -918,6 +931,7 @@ package body Par_SCO is
procedure SCO_Output is procedure SCO_Output is
procedure Populate_SCO_Instance_Table is procedure Populate_SCO_Instance_Table is
new Sinput.Iterate_On_Instances (Record_Instance); new Sinput.Iterate_On_Instances (Record_Instance);
begin begin
pragma Assert (SCO_Generation_State = Filtered); pragma Assert (SCO_Generation_State = Filtered);
...@@ -930,8 +944,7 @@ package body Par_SCO is ...@@ -930,8 +944,7 @@ package body Par_SCO is
-- Sort the unit tables based on dependency numbers -- Sort the unit tables based on dependency numbers
Unit_Table_Sort : declare Unit_Table_Sort : declare
function Lt (Op1 : Natural; Op2 : Natural) return Boolean;
function Lt (Op1, Op2 : Natural) return Boolean;
-- Comparison routine for sort call -- Comparison routine for sort call
procedure Move (From : Natural; To : Natural); procedure Move (From : Natural; To : Natural);
...@@ -941,7 +954,7 @@ package body Par_SCO is ...@@ -941,7 +954,7 @@ package body Par_SCO is
-- Lt -- -- Lt --
-------- --------
function Lt (Op1, Op2 : Natural) return Boolean is function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
begin begin
return return
Dependency_Num Dependency_Num
...@@ -978,6 +991,7 @@ package body Par_SCO is ...@@ -978,6 +991,7 @@ package body Par_SCO is
declare declare
U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J); U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J); UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
begin begin
Get_Name_String (Reference_Name (Source_Index (U))); Get_Name_String (Reference_Name (Source_Index (U)));
UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len)); UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
...@@ -1050,9 +1064,6 @@ package body Par_SCO is ...@@ -1050,9 +1064,6 @@ package body Par_SCO is
-------------------- --------------------
procedure SCO_Record_Raw (U : Unit_Number_Type) is procedure SCO_Record_Raw (U : Unit_Number_Type) is
Lu : Node_Id;
From : Nat;
procedure Traverse_Aux_Decls (N : Node_Id); procedure Traverse_Aux_Decls (N : Node_Id);
-- Traverse the Aux_Decls_Node of compilation unit N -- Traverse the Aux_Decls_Node of compilation unit N
...@@ -1062,6 +1073,7 @@ package body Par_SCO is ...@@ -1062,6 +1073,7 @@ package body Par_SCO is
procedure Traverse_Aux_Decls (N : Node_Id) is procedure Traverse_Aux_Decls (N : Node_Id) is
ADN : constant Node_Id := Aux_Decls_Node (N); ADN : constant Node_Id := Aux_Decls_Node (N);
begin begin
Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
...@@ -1074,6 +1086,11 @@ package body Par_SCO is ...@@ -1074,6 +1086,11 @@ package body Par_SCO is
pragma Assert (No (Actions (ADN))); pragma Assert (No (Actions (ADN)));
end Traverse_Aux_Decls; end Traverse_Aux_Decls;
-- Local variables
From : Nat;
Lu : Node_Id;
-- Start of processing for SCO_Record_Raw -- Start of processing for SCO_Record_Raw
begin begin
...@@ -1114,16 +1131,14 @@ package body Par_SCO is ...@@ -1114,16 +1131,14 @@ package body Par_SCO is
Traverse_Aux_Decls (Cunit (U)); Traverse_Aux_Decls (Cunit (U));
case Nkind (Lu) is case Nkind (Lu) is
when when N_Generic_Instantiation |
N_Package_Declaration | N_Generic_Package_Declaration |
N_Package_Body | N_Package_Body |
N_Subprogram_Declaration | N_Package_Declaration |
N_Subprogram_Body | N_Protected_Body |
N_Generic_Package_Declaration | N_Subprogram_Body |
N_Protected_Body | N_Subprogram_Declaration |
N_Task_Body | N_Task_Body =>
N_Generic_Instantiation =>
Traverse_Declarations_Or_Statements (L => No_List, P => Lu); Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
when others => when others =>
...@@ -1157,13 +1172,14 @@ package body Par_SCO is ...@@ -1157,13 +1172,14 @@ package body Par_SCO is
pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw); pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
Constant_Condition_Code : constant array (Boolean) of Character :=
(False => 'f', True => 't');
Orig : constant Node_Id := Original_Node (Cond); Orig : constant Node_Id := Original_Node (Cond);
Dummy : Source_Ptr;
Index : Nat; Index : Nat;
Start : Source_Ptr; Start : Source_Ptr;
Dummy : Source_Ptr;
Constant_Condition_Code : constant array (Boolean) of Character :=
(False => 'f', True => 't');
begin begin
Sloc_Range (Orig, Start, Dummy); Sloc_Range (Orig, Start, Dummy);
Index := SCO_Raw_Hash_Table.Get (Start); Index := SCO_Raw_Hash_Table.Get (Start);
...@@ -1191,9 +1207,9 @@ package body Par_SCO is ...@@ -1191,9 +1207,9 @@ package body Par_SCO is
pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw); pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
Orig : constant Node_Id := Original_Node (Op); Orig : constant Node_Id := Original_Node (Op);
Orig_Sloc : constant Source_Ptr := Sloc (Orig); Orig_Sloc : constant Source_Ptr := Sloc (Orig);
Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc); Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
begin begin
-- All (putative) logical operators are supposed to have their own entry -- All (putative) logical operators are supposed to have their own entry
...@@ -1333,25 +1349,25 @@ package body Par_SCO is ...@@ -1333,25 +1349,25 @@ package body Par_SCO is
-- the range of entries in the CS line entry, and typ is the type, with -- the range of entries in the CS line entry, and typ is the type, with
-- space meaning that no type letter will accompany the entry. -- space meaning that no type letter will accompany the entry.
package SC is new Table.Table ( package SC is new Table.Table
Table_Component_Type => SC_Entry, (Table_Component_Type => SC_Entry,
Table_Index_Type => Nat, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 1000, Table_Initial => 1000,
Table_Increment => 200, Table_Increment => 200,
Table_Name => "SCO_SC"); Table_Name => "SCO_SC");
-- Used to store statement components for a CS entry to be output -- Used to store statement components for a CS entry to be output as a
-- as a result of the call to this procedure. SC.Last is the last -- result of the call to this procedure. SC.Last is the last entry stored,
-- entry stored, so the current statement sequence is represented -- so the current statement sequence is represented by SC_Array (SC_First
-- by SC_Array (SC_First .. SC.Last), where SC_First is saved on -- .. SC.Last), where SC_First is saved on entry to each recursive call to
-- entry to each recursive call to the routine. -- the routine.
-- --
-- Extend_Statement_Sequence adds an entry to this array, and then -- Extend_Statement_Sequence adds an entry to this array, and then
-- Set_Statement_Entry clears the entries starting with SC_First, -- Set_Statement_Entry clears the entries starting with SC_First, copying
-- copying these entries to the main SCO output table. The reason that -- these entries to the main SCO output table. The reason that we do the
-- we do the temporary caching of results in this array is that we want -- temporary caching of results in this array is that we want the SCO table
-- the SCO table entries for a given CS line to be contiguous, and the -- entries for a given CS line to be contiguous, and the processing may
-- processing may output intermediate entries such as decision entries. -- output intermediate entries such as decision entries.
type SD_Entry is record type SD_Entry is record
Nod : Node_Id; Nod : Node_Id;
...@@ -1366,13 +1382,13 @@ package body Par_SCO is ...@@ -1366,13 +1382,13 @@ package body Par_SCO is
-- argument (in which case Nod is set to Empty). Plo is the sloc of the -- argument (in which case Nod is set to Empty). Plo is the sloc of the
-- enclosing pragma, if any. -- enclosing pragma, if any.
package SD is new Table.Table ( package SD is new Table.Table
Table_Component_Type => SD_Entry, (Table_Component_Type => SD_Entry,
Table_Index_Type => Nat, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 1000, Table_Initial => 1000,
Table_Increment => 200, Table_Increment => 200,
Table_Name => "SCO_SD"); Table_Name => "SCO_SD");
-- Used to store possible decision information. Instead of calling the -- Used to store possible decision information. Instead of calling the
-- Process_Decisions procedures directly, we call Process_Decisions_Defer, -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
-- which simply stores the arguments in this table. Then when we clear -- which simply stores the arguments in this table. Then when we clear
...@@ -1415,11 +1431,6 @@ package body Par_SCO is ...@@ -1415,11 +1431,6 @@ package body Par_SCO is
-- is the letter that identifies the type of statement/declaration that -- is the letter that identifies the type of statement/declaration that
-- is being added to the sequence. -- is being added to the sequence.
procedure Set_Statement_Entry;
-- Output CS entries for all statements saved in table SC, and end the
-- current CS sequence. Then output entries for all decisions nested in
-- these statements, which have been deferred so far.
procedure Process_Decisions_Defer (N : Node_Id; T : Character); procedure Process_Decisions_Defer (N : Node_Id; T : Character);
pragma Inline (Process_Decisions_Defer); pragma Inline (Process_Decisions_Defer);
-- This routine is logically the same as Process_Decisions, except that -- This routine is logically the same as Process_Decisions, except that
...@@ -1431,12 +1442,95 @@ package body Par_SCO is ...@@ -1431,12 +1442,95 @@ package body Par_SCO is
pragma Inline (Process_Decisions_Defer); pragma Inline (Process_Decisions_Defer);
-- Same case for list arguments, deferred call to Process_Decisions -- Same case for list arguments, deferred call to Process_Decisions
procedure Set_Statement_Entry;
-- Output CS entries for all statements saved in table SC, and end the
-- current CS sequence. Then output entries for all decisions nested in
-- these statements, which have been deferred so far.
procedure Traverse_One (N : Node_Id); procedure Traverse_One (N : Node_Id);
-- Traverse one declaration or statement -- Traverse one declaration or statement
procedure Traverse_Aspects (N : Node_Id); procedure Traverse_Aspects (N : Node_Id);
-- Helper for Traverse_One: traverse N's aspect specifications -- Helper for Traverse_One: traverse N's aspect specifications
-------------------------------
-- Extend_Statement_Sequence --
-------------------------------
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
Dummy : Source_Ptr;
F : Source_Ptr;
T : Source_Ptr;
To_Node : Node_Id := Empty;
begin
Sloc_Range (N, F, T);
case Nkind (N) is
when N_Accept_Statement =>
if Present (Parameter_Specifications (N)) then
To_Node := Last (Parameter_Specifications (N));
elsif Present (Entry_Index (N)) then
To_Node := Entry_Index (N);
end if;
when N_Case_Statement =>
To_Node := Expression (N);
when N_If_Statement | N_Elsif_Part =>
To_Node := Condition (N);
when N_Extended_Return_Statement =>
To_Node := Last (Return_Object_Declarations (N));
when N_Loop_Statement =>
To_Node := Iteration_Scheme (N);
when N_Asynchronous_Select |
N_Conditional_Entry_Call |
N_Selective_Accept |
N_Single_Protected_Declaration |
N_Single_Task_Declaration |
N_Timed_Entry_Call =>
T := F;
when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
if Has_Aspects (N) then
To_Node := Last (Aspect_Specifications (N));
elsif Present (Discriminant_Specifications (N)) then
To_Node := Last (Discriminant_Specifications (N));
else
To_Node := Defining_Identifier (N);
end if;
when others =>
null;
end case;
if Present (To_Node) then
Sloc_Range (To_Node, Dummy, T);
end if;
SC.Append ((N, F, T, Typ));
end Extend_Statement_Sequence;
-----------------------------
-- Process_Decisions_Defer --
-----------------------------
procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
begin
SD.Append ((N, No_List, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
procedure Process_Decisions_Defer (L : List_Id; T : Character) is
begin
SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
------------------------- -------------------------
-- Set_Statement_Entry -- -- Set_Statement_Entry --
------------------------- -------------------------
...@@ -1453,12 +1547,16 @@ package body Par_SCO is ...@@ -1453,12 +1547,16 @@ package body Par_SCO is
if Current_Dominant /= No_Dominant then if Current_Dominant /= No_Dominant then
declare declare
From, To : Source_Ptr; From : Source_Ptr;
To : Source_Ptr;
begin begin
Sloc_Range (Current_Dominant.N, From, To); Sloc_Range (Current_Dominant.N, From, To);
if Current_Dominant.K /= 'E' then if Current_Dominant.K /= 'E' then
To := No_Location; To := No_Location;
end if; end if;
Set_Raw_Table_Entry Set_Raw_Table_Entry
(C1 => '>', (C1 => '>',
C2 => Current_Dominant.K, C2 => Current_Dominant.K,
...@@ -1475,6 +1573,7 @@ package body Par_SCO is ...@@ -1475,6 +1573,7 @@ package body Par_SCO is
SCE : SC_Entry renames SC.Table (J); SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location; Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Aspect_Name : Name_Id := No_Name; Pragma_Aspect_Name : Name_Id := No_Name;
begin begin
-- For the case of a statement SCO for a pragma controlled by -- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
...@@ -1520,6 +1619,7 @@ package body Par_SCO is ...@@ -1520,6 +1619,7 @@ package body Par_SCO is
for J in SD_First .. SD_Last loop for J in SD_First .. SD_Last loop
declare declare
SDE : SD_Entry renames SD.Table (J); SDE : SD_Entry renames SD.Table (J);
begin begin
if Present (SDE.Nod) then if Present (SDE.Nod) then
Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
...@@ -1534,91 +1634,13 @@ package body Par_SCO is ...@@ -1534,91 +1634,13 @@ package body Par_SCO is
SD.Set_Last (SD_First - 1); SD.Set_Last (SD_First - 1);
end Set_Statement_Entry; end Set_Statement_Entry;
-------------------------------
-- Extend_Statement_Sequence --
-------------------------------
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
F : Source_Ptr;
T : Source_Ptr;
Dummy : Source_Ptr;
To_Node : Node_Id := Empty;
begin
Sloc_Range (N, F, T);
case Nkind (N) is
when N_Accept_Statement =>
if Present (Parameter_Specifications (N)) then
To_Node := Last (Parameter_Specifications (N));
elsif Present (Entry_Index (N)) then
To_Node := Entry_Index (N);
end if;
when N_Case_Statement =>
To_Node := Expression (N);
when N_If_Statement | N_Elsif_Part =>
To_Node := Condition (N);
when N_Extended_Return_Statement =>
To_Node := Last (Return_Object_Declarations (N));
when N_Loop_Statement =>
To_Node := Iteration_Scheme (N);
when N_Selective_Accept |
N_Timed_Entry_Call |
N_Conditional_Entry_Call |
N_Asynchronous_Select |
N_Single_Protected_Declaration |
N_Single_Task_Declaration =>
T := F;
when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
if Has_Aspects (N) then
To_Node := Last (Aspect_Specifications (N));
elsif Present (Discriminant_Specifications (N)) then
To_Node := Last (Discriminant_Specifications (N));
else
To_Node := Defining_Identifier (N);
end if;
when others =>
null;
end case;
if Present (To_Node) then
Sloc_Range (To_Node, Dummy, T);
end if;
SC.Append ((N, F, T, Typ));
end Extend_Statement_Sequence;
-----------------------------
-- Process_Decisions_Defer --
-----------------------------
procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
begin
SD.Append ((N, No_List, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
procedure Process_Decisions_Defer (L : List_Id; T : Character) is
begin
SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
---------------------- ----------------------
-- Traverse_Aspects -- -- Traverse_Aspects --
---------------------- ----------------------
procedure Traverse_Aspects (N : Node_Id) is procedure Traverse_Aspects (N : Node_Id) is
AN : Node_Id;
AE : Node_Id; AE : Node_Id;
AN : Node_Id;
C1 : Character; C1 : Character;
begin begin
...@@ -1640,13 +1662,12 @@ package body Par_SCO is ...@@ -1640,13 +1662,12 @@ package body Par_SCO is
-- specification. The corresponding pragma will have the same -- specification. The corresponding pragma will have the same
-- sloc. -- sloc.
when Aspect_Pre | when Aspect_Invariant |
Aspect_Precondition |
Aspect_Post | Aspect_Post |
Aspect_Postcondition | Aspect_Postcondition |
Aspect_Type_Invariant | Aspect_Pre |
Aspect_Invariant => Aspect_Precondition |
Aspect_Type_Invariant =>
C1 := 'a'; C1 := 'a';
-- Aspects whose checks are generated in client units, -- Aspects whose checks are generated in client units,
...@@ -1659,17 +1680,15 @@ package body Par_SCO is ...@@ -1659,17 +1680,15 @@ package body Par_SCO is
-- Pre/post can have checks in client units too because of -- Pre/post can have checks in client units too because of
-- inheritance, so should they be moved here??? -- inheritance, so should they be moved here???
when Aspect_Predicate | when Aspect_Dynamic_Predicate |
Aspect_Static_Predicate | Aspect_Predicate |
Aspect_Dynamic_Predicate => Aspect_Static_Predicate =>
C1 := 'A'; C1 := 'A';
-- Other aspects: just process any decision nested in the -- Other aspects: just process any decision nested in the
-- aspect expression. -- aspect expression.
when others => when others =>
if Has_Decision (AE) then if Has_Decision (AE) then
C1 := 'X'; C1 := 'X';
end if; end if;
...@@ -1901,7 +1920,7 @@ package body Par_SCO is ...@@ -1901,7 +1920,7 @@ package body Par_SCO is
declare declare
Alt : Node_Id; Alt : Node_Id;
begin begin
Alt := First (Alternatives (N)); Alt := First_Non_Pragma (Alternatives (N));
while Present (Alt) loop while Present (Alt) loop
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements
(L => Statements (Alt), (L => Statements (Alt),
...@@ -2043,8 +2062,7 @@ package body Par_SCO is ...@@ -2043,8 +2062,7 @@ package body Par_SCO is
when N_Extended_Return_Statement => when N_Extended_Return_Statement =>
Extend_Statement_Sequence (N, 'R'); Extend_Statement_Sequence (N, 'R');
Process_Decisions_Defer Process_Decisions_Defer (Return_Object_Declarations (N), 'X');
(Return_Object_Declarations (N), 'X');
Set_Statement_Entry; Set_Statement_Entry;
Traverse_Handled_Statement_Sequence Traverse_Handled_Statement_Sequence
...@@ -2126,8 +2144,8 @@ package body Par_SCO is ...@@ -2126,8 +2144,8 @@ package body Par_SCO is
Name_Assume | Name_Assume |
Name_Check | Name_Check |
Name_Loop_Invariant | Name_Loop_Invariant |
Name_Precondition | Name_Postcondition |
Name_Postcondition => Name_Precondition =>
-- For Assert/Check/Precondition/Postcondition, we -- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note -- must generate a P entry for the decision. Note
...@@ -2224,8 +2242,8 @@ package body Par_SCO is ...@@ -2224,8 +2242,8 @@ package body Par_SCO is
case NK is case NK is
when N_Full_Type_Declaration | when N_Full_Type_Declaration |
N_Incomplete_Type_Declaration | N_Incomplete_Type_Declaration |
N_Private_Type_Declaration | N_Private_Extension_Declaration |
N_Private_Extension_Declaration => N_Private_Type_Declaration =>
Typ := 't'; Typ := 't';
when N_Subtype_Declaration => when N_Subtype_Declaration =>
...@@ -2237,12 +2255,12 @@ package body Par_SCO is ...@@ -2237,12 +2255,12 @@ package body Par_SCO is
when N_Generic_Instantiation => when N_Generic_Instantiation =>
Typ := 'i'; Typ := 'i';
when N_Representation_Clause | when N_Package_Body_Stub |
N_Use_Package_Clause | N_Protected_Body_Stub |
N_Use_Type_Clause | N_Representation_Clause |
N_Package_Body_Stub |
N_Task_Body_Stub | N_Task_Body_Stub |
N_Protected_Body_Stub => N_Use_Package_Clause |
N_Use_Type_Clause =>
Typ := ASCII.NUL; Typ := ASCII.NUL;
when N_Procedure_Call_Statement => when N_Procedure_Call_Statement =>
...@@ -2338,7 +2356,7 @@ package body Par_SCO is ...@@ -2338,7 +2356,7 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Statements (N), D); Traverse_Declarations_Or_Statements (Statements (N), D);
if Present (Exception_Handlers (N)) then if Present (Exception_Handlers (N)) then
Handler := First (Exception_Handlers (N)); Handler := First_Non_Pragma (Exception_Handlers (N));
while Present (Handler) loop while Present (Handler) loop
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements
(L => Statements (Handler), (L => Statements (Handler),
...@@ -2397,15 +2415,18 @@ package body Par_SCO is ...@@ -2397,15 +2415,18 @@ package body Par_SCO is
Sync_Def : Node_Id; Sync_Def : Node_Id;
-- N's protected or task definition -- N's protected or task definition
Vis_Decl, Priv_Decl : List_Id; Priv_Decl : List_Id;
Vis_Decl : List_Id;
-- Sync_Def's Visible_Declarations and Private_Declarations -- Sync_Def's Visible_Declarations and Private_Declarations
begin begin
case Nkind (N) is case Nkind (N) is
when N_Single_Protected_Declaration | N_Protected_Type_Declaration => when N_Protected_Type_Declaration |
N_Single_Protected_Declaration =>
Sync_Def := Protected_Definition (N); Sync_Def := Protected_Definition (N);
when N_Single_Task_Declaration | N_Task_Type_Declaration => when N_Single_Task_Declaration |
N_Task_Type_Declaration =>
Sync_Def := Task_Definition (N); Sync_Def := Task_Definition (N);
when others => when others =>
...@@ -2416,10 +2437,10 @@ package body Par_SCO is ...@@ -2416,10 +2437,10 @@ package body Par_SCO is
-- Querying Visible or Private_Declarations is invalid in this case. -- Querying Visible or Private_Declarations is invalid in this case.
if Present (Sync_Def) then if Present (Sync_Def) then
Vis_Decl := Visible_Declarations (Sync_Def); Vis_Decl := Visible_Declarations (Sync_Def);
Priv_Decl := Private_Declarations (Sync_Def); Priv_Decl := Private_Declarations (Sync_Def);
else else
Vis_Decl := No_List; Vis_Decl := No_List;
Priv_Decl := No_List; Priv_Decl := No_List;
end if; end if;
...@@ -2444,7 +2465,8 @@ package body Par_SCO is ...@@ -2444,7 +2465,8 @@ package body Par_SCO is
D : Dominant_Info := No_Dominant) D : Dominant_Info := No_Dominant)
is is
Decls : constant List_Id := Declarations (N); Decls : constant List_Id := Declarations (N);
Dom_Info : Dominant_Info := D; Dom_Info : Dominant_Info := D;
begin begin
-- If declarations are present, the first statement is dominated by the -- If declarations are present, the first statement is dominated by the
-- last declaration. -- last declaration.
...@@ -2484,23 +2506,9 @@ package body Par_SCO is ...@@ -2484,23 +2506,9 @@ package body Par_SCO is
Table_Name => "Filter_Pending_Decisions"); Table_Name => "Filter_Pending_Decisions");
-- Table used to hold decisions to process during the collection pass -- Table used to hold decisions to process during the collection pass
function Is_Decision (Idx : Nat) return Boolean; procedure Add_Expression_Tree (Idx : in out Nat);
-- Return if the expression tree starting at Idx has adjacent nested -- Add SCO raw table entries for the decision controlling expression
-- nodes that make a decision. -- tree starting at Idx to the filtered SCO table.
procedure Search_Nested_Decisions (Idx : in out Nat);
-- Collect decisions to add to the filtered SCO table starting at the
-- node at Idx in the SCO raw table. This node must not be part of an
-- already-processed decision. Set Idx to the first node index passed
-- the whole expression tree.
procedure Skip_Decision
(Idx : in out Nat;
Process_Nested_Decisions : Boolean);
-- Skip all the nodes that belong to the decision starting at Idx. If
-- Process_Nested_Decision, call Search_Nested_Decisions on the first
-- nested nodes that do not belong to the decision. Set Idx to the first
-- node index passed the whole expression tree.
procedure Collect_Decisions procedure Collect_Decisions
(D : Decision; (D : Decision;
...@@ -2516,149 +2524,87 @@ package body Par_SCO is ...@@ -2516,149 +2524,87 @@ package body Par_SCO is
-- Compute the source location range for the expression tree starting at -- Compute the source location range for the expression tree starting at
-- Idx in the SCO raw table. Store its bounds in From and To. -- Idx in the SCO raw table. Store its bounds in From and To.
procedure Add_Expression_Tree (Idx : in out Nat); function Is_Decision (Idx : Nat) return Boolean;
-- Add SCO raw table entries for the decision controlling expression -- Return if the expression tree starting at Idx has adjacent nested
-- tree starting at Idx to the filtered SCO table. -- nodes that make a decision.
procedure Process_Pending_Decisions procedure Process_Pending_Decisions
(Original_Decision : SCO_Table_Entry); (Original_Decision : SCO_Table_Entry);
-- Complete the filtered SCO table using collected decisions. Output -- Complete the filtered SCO table using collected decisions. Output
-- decisions inherit the pragma information from the original decision. -- decisions inherit the pragma information from the original decision.
----------------- procedure Search_Nested_Decisions (Idx : in out Nat);
-- Is_Decision -- -- Collect decisions to add to the filtered SCO table starting at the
----------------- -- node at Idx in the SCO raw table. This node must not be part of an
-- already-processed decision. Set Idx to the first node index passed
function Is_Decision (Idx : Nat) return Boolean is -- the whole expression tree.
Index : Nat := Idx;
begin procedure Skip_Decision
loop (Idx : in out Nat;
declare Process_Nested_Decisions : Boolean);
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index); -- Skip all the nodes that belong to the decision starting at Idx. If
-- Process_Nested_Decision, call Search_Nested_Decisions on the first
begin -- nested nodes that do not belong to the decision. Set Idx to the first
case T.C1 is -- node index passed the whole expression tree.
when ' ' =>
return False;
when '!' =>
-- This is a decision iff the only operand of the NOT
-- operator could be a standalone decision.
Index := Idx + 1;
when others =>
-- This node is a logical operator (and thus could be a
-- standalone decision) iff it is a short circuit
-- operator.
return T.C2 /= '?';
end case; -------------------------
end; -- Add_Expression_Tree --
end loop; -------------------------
end Is_Decision;
----------------------------- procedure Add_Expression_Tree (Idx : in out Nat) is
-- Search_Nested_Decisions -- Node_Idx : constant Nat := Idx;
----------------------------- T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
From : Source_Location;
To : Source_Location;
procedure Search_Nested_Decisions (Idx : in out Nat)
is
begin begin
loop case T.C1 is
declare when ' ' =>
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
begin
case T.C1 is
when ' ' =>
Idx := Idx + 1;
exit;
when '!' =>
Collect_Decisions
((Kind => 'X',
Sloc => T.From,
Top => Idx),
Idx);
exit;
when others =>
if T.C2 = '?' then
-- This in not a logical operator: start looking for
-- nested decisions from here. Recurse over the left
-- child and let the loop take care of the right one.
Idx := Idx + 1;
Search_Nested_Decisions (Idx);
else -- This is a single condition. Add an entry for it and move on
-- We found a nested decision
Collect_Decisions SCO_Table.Append (T);
((Kind => 'X', Idx := Idx + 1;
Sloc => T.From,
Top => Idx),
Idx);
exit;
end if;
end case;
end;
end loop;
end Search_Nested_Decisions;
------------------- when '!' =>
-- Skip_Decision --
-------------------
procedure Skip_Decision -- This is a NOT operator: add an entry for it and browse its
(Idx : in out Nat; -- only child.
Process_Nested_Decisions : Boolean)
is
begin
loop
declare
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
begin SCO_Table.Append (T);
Idx := Idx + 1; Idx := Idx + 1;
Add_Expression_Tree (Idx);
case T.C1 is when others =>
when ' ' =>
exit;
when '!' =>
-- This NOT operator belongs to the outside decision:
-- just skip it.
null; -- This must be an AND/OR/AND THEN/OR ELSE operator
when others => if T.C2 = '?' then
if T.C2 = '?' and then Process_Nested_Decisions then
-- This in not a logical operator: start looking for -- This is not a short circuit operator: consider this one
-- nested decisions from here. Recurse over the left -- and all its children as a single condition.
-- child and let the loop take care of the right one.
Search_Nested_Decisions (Idx); Compute_Range (Idx, From, To);
SCO_Table.Append
((From => From,
To => To,
C1 => ' ',
C2 => 'c',
Last => False,
Pragma_Sloc => No_Location,
Pragma_Aspect_Name => No_Name));
else else
-- This is a logical operator, so it belongs to the -- This is a real short circuit operator: add an entry for
-- outside decision: skip its left child, then let the -- it and browse its children.
-- loop take care of the right one.
Skip_Decision (Idx, Process_Nested_Decisions); SCO_Table.Append (T);
end if; Idx := Idx + 1;
end case; Add_Expression_Tree (Idx);
end; Add_Expression_Tree (Idx);
end loop; end if;
end Skip_Decision; end case;
end Add_Expression_Tree;
----------------------- -----------------------
-- Collect_Decisions -- -- Collect_Decisions --
...@@ -2669,6 +2615,7 @@ package body Par_SCO is ...@@ -2669,6 +2615,7 @@ package body Par_SCO is
Next : out Nat) Next : out Nat)
is is
Idx : Nat := D.Top; Idx : Nat := D.Top;
begin begin
if D.Kind /= 'X' or else Is_Decision (D.Top) then if D.Kind /= 'X' or else Is_Decision (D.Top) then
Pending_Decisions.Append (D); Pending_Decisions.Append (D);
...@@ -2687,7 +2634,8 @@ package body Par_SCO is ...@@ -2687,7 +2634,8 @@ package body Par_SCO is
From : out Source_Location; From : out Source_Location;
To : out Source_Location) To : out Source_Location)
is is
Sloc_F, Sloc_T : Source_Location := No_Source_Location; Sloc_F : Source_Location := No_Source_Location;
Sloc_T : Source_Location := No_Source_Location;
procedure Process_One; procedure Process_One;
-- Process one node of the tree, and recurse over children. Update -- Process one node of the tree, and recurse over children. Update
...@@ -2705,6 +2653,7 @@ package body Par_SCO is ...@@ -2705,6 +2653,7 @@ package body Par_SCO is
then then
Sloc_F := SCO_Raw_Table.Table (Idx).From; Sloc_F := SCO_Raw_Table.Table (Idx).From;
end if; end if;
if Sloc_T = No_Source_Location if Sloc_T = No_Source_Location
or else or else
Sloc_T < SCO_Raw_Table.Table (Idx).To Sloc_T < SCO_Raw_Table.Table (Idx).To
...@@ -2741,67 +2690,45 @@ package body Par_SCO is ...@@ -2741,67 +2690,45 @@ package body Par_SCO is
begin begin
Process_One; Process_One;
From := Sloc_F; From := Sloc_F;
To := Sloc_T; To := Sloc_T;
end Compute_Range; end Compute_Range;
------------------------- -----------------
-- Add_Expression_Tree -- -- Is_Decision --
------------------------- -----------------
procedure Add_Expression_Tree (Idx : in out Nat) function Is_Decision (Idx : Nat) return Boolean is
is Index : Nat := Idx;
Node_Idx : constant Nat := Idx;
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
From, To : Source_Location;
begin begin
case T.C1 is loop
when ' ' => declare
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
-- This is a single condition. Add an entry for it and move on
SCO_Table.Append (T);
Idx := Idx + 1;
when '!' =>
-- This is a NOT operator: add an entry for it and browse its
-- only child.
SCO_Table.Append (T); begin
Idx := Idx + 1; case T.C1 is
Add_Expression_Tree (Idx); when ' ' =>
return False;
when others => when '!' =>
-- This must be an AND/OR/AND THEN/OR ELSE operator -- This is a decision iff the only operand of the NOT
-- operator could be a standalone decision.
if T.C2 = '?' then Index := Idx + 1;
-- This is not a short circuit operator: consider this one when others =>
-- and all its children as a single condition.
Compute_Range (Idx, From, To); -- This node is a logical operator (and thus could be a
SCO_Table.Append -- standalone decision) iff it is a short circuit
((From => From, -- operator.
To => To,
C1 => ' ',
C2 => 'c',
Last => False,
Pragma_Sloc => No_Location,
Pragma_Aspect_Name => No_Name));
else return T.C2 /= '?';
-- This is a real short circuit operator: add an entry for
-- it and browse its children.
SCO_Table.Append (T); end case;
Idx := Idx + 1; end;
Add_Expression_Tree (Idx); end loop;
Add_Expression_Tree (Idx); end Is_Decision;
end if;
end case;
end Add_Expression_Tree;
------------------------------- -------------------------------
-- Process_Pending_Decisions -- -- Process_Pending_Decisions --
...@@ -2843,6 +2770,103 @@ package body Par_SCO is ...@@ -2843,6 +2770,103 @@ package body Par_SCO is
Pending_Decisions.Set_Last (0); Pending_Decisions.Set_Last (0);
end Process_Pending_Decisions; end Process_Pending_Decisions;
-----------------------------
-- Search_Nested_Decisions --
-----------------------------
procedure Search_Nested_Decisions (Idx : in out Nat) is
begin
loop
declare
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
begin
case T.C1 is
when ' ' =>
Idx := Idx + 1;
exit;
when '!' =>
Collect_Decisions
((Kind => 'X',
Sloc => T.From,
Top => Idx),
Idx);
exit;
when others =>
if T.C2 = '?' then
-- This in not a logical operator: start looking for
-- nested decisions from here. Recurse over the left
-- child and let the loop take care of the right one.
Idx := Idx + 1;
Search_Nested_Decisions (Idx);
else
-- We found a nested decision
Collect_Decisions
((Kind => 'X',
Sloc => T.From,
Top => Idx),
Idx);
exit;
end if;
end case;
end;
end loop;
end Search_Nested_Decisions;
-------------------
-- Skip_Decision --
-------------------
procedure Skip_Decision
(Idx : in out Nat;
Process_Nested_Decisions : Boolean)
is
begin
loop
declare
T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
begin
Idx := Idx + 1;
case T.C1 is
when ' ' =>
exit;
when '!' =>
-- This NOT operator belongs to the outside decision:
-- just skip it.
null;
when others =>
if T.C2 = '?' and then Process_Nested_Decisions then
-- This in not a logical operator: start looking for
-- nested decisions from here. Recurse over the left
-- child and let the loop take care of the right one.
Search_Nested_Decisions (Idx);
else
-- This is a logical operator, so it belongs to the
-- outside decision: skip its left child, then let the
-- loop take care of the right one.
Skip_Decision (Idx, Process_Nested_Decisions);
end if;
end case;
end;
end loop;
end Skip_Decision;
-- Start of processing for SCO_Record_Filtered -- Start of processing for SCO_Record_Filtered
begin begin
...@@ -2861,7 +2885,7 @@ package body Par_SCO is ...@@ -2861,7 +2885,7 @@ package body Par_SCO is
for Unit_Idx in 1 .. SCO_Unit_Table.Last loop for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
declare declare
Unit : SCO_Unit_Table_Entry Unit : SCO_Unit_Table_Entry
renames SCO_Unit_Table.Table (Unit_Idx); renames SCO_Unit_Table.Table (Unit_Idx);
Idx : Nat := Unit.From; Idx : Nat := Unit.From;
-- Index of the current SCO raw table entry -- Index of the current SCO raw table entry
...@@ -2921,7 +2945,7 @@ package body Par_SCO is ...@@ -2921,7 +2945,7 @@ package body Par_SCO is
-- Now, update the SCO entry indexes in the unit entry -- Now, update the SCO entry indexes in the unit entry
Unit.From := New_From; Unit.From := New_From;
Unit.To := SCO_Table.Last; Unit.To := SCO_Table.Last;
end; end;
end loop; end loop;
......
gcc/ada/s-osinte-darwin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2015, 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- --
...@@ -172,17 +172,6 @@ package body System.OS_Interface is ...@@ -172,17 +172,6 @@ package body System.OS_Interface is
return 0; return 0;
end sched_yield; end sched_yield;
--------------
-- lwp_self --
--------------
function lwp_self return Address is
function pthread_mach_thread_np (thread : pthread_t) return Address;
pragma Import (C, pthread_mach_thread_np, "pthread_mach_thread_np");
begin
return pthread_mach_thread_np (pthread_self);
end lwp_self;
------------------ ------------------
-- pthread_init -- -- pthread_init --
------------------ ------------------
......
gcc/ada/s-osinte-darwin.ads
...@@ -228,6 +228,7 @@ package System.OS_Interface is ...@@ -228,6 +228,7 @@ package System.OS_Interface is
--------- ---------
function lwp_self return System.Address; function lwp_self return System.Address;
pragma Import (C, lwp_self, "__gnat_lwp_self");
-- Return the mach thread bound to the current thread. The value is not -- Return the mach thread bound to the current thread. The value is not
-- used by the run-time library but made available to debuggers. -- used by the run-time library but made available to debuggers.
......
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