summaryrefslogtreecommitdiff
path: root/gcc/ada/par_sco.adb
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2011-08-05 14:18:09 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2011-08-05 14:18:09 +0000
commitcf365b48fc59b488e2cbf831dc2e9e8f59dfe0fa (patch)
tree1a26e8ca549a60121572a15150d39632dbafbb1a /gcc/ada/par_sco.adb
parent7947a43964decdb9632653e3afa1a07030cf7c8e (diff)
downloadgcc-cf365b48fc59b488e2cbf831dc2e9e8f59dfe0fa.tar.gz
2011-08-05 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Set_All_DT_Position): Cleanup code and improve support for renamings of predefined primitives. (In_Predef_Prims_DT): New subprogram. 2011-08-05 Ed Schonberg <schonberg@adacore.com> * sem_util.adb, sem_util.ads (Check_Implicit_Dereference): If a possible interpretation of name is a reference type, add an interpretation that is the designated type of the reference discriminant of that type. * sem_res.adb (resolve): If the interpretation imposed by context is an implicit dereference, rewrite the node as the deference of the reference discriminant. * sem_ch3.adb (Analyze_Subtype_Declaration, Build_Derived_Record_Type, Build_Discriminated_Subtype): Inherit Has_Implicit_Dereference from parent type or base type. * sem_ch4.adb (Process_Indexed_Component, Process_Overloaded_Indexed_Component, Indicate_Name_And_Type, Analyze_Overloaded_Selected_Component, Analyze_Selected_Component): Check for implicit dereference. (List_Operand_Interps): Indicate when an implicit dereference is ambiguous. * sem_ch8.adb (Find_Direct_Name): Check for implicit dereference. 2011-08-05 Thomas Quinot <quinot@adacore.com> * scos.ads: Update documentation of SCO table. Pragma statements can now be marked as disabled (using 'p' instead of 'P' as the statement kind). * par_sco.ads, par_sco.adb: Implement the above change. (Process_Decisions_Defer): Generate a P decision for the first parameter of a dyadic pragma Debug. * sem_prag.adb (Analyze_Pragma, case Debug): Mark pragma as enabled if necessary. * put_scos.adb: Code simplification based on above change. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177442 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/par_sco.adb')
-rw-r--r--gcc/ada/par_sco.adb195
1 files changed, 115 insertions, 80 deletions
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index 2feec9c4471..8f76dd25039 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -69,9 +69,9 @@ package body Par_SCO is
-- We need to be able to get to conditions quickly for handling the calls
-- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
- -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
- -- conditions and pragmas in the table by their starting sloc, and use this
- -- hash table to map from these starting sloc values to SCO_Table indexes.
+ -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify
+ -- the conditions and pragmas in the table by their starting sloc, and use
+ -- this hash table to map from these sloc values to SCO_Table indexes.
type Header_Num is new Integer range 0 .. 996;
-- Type for hash table headers
@@ -101,7 +101,10 @@ package body Par_SCO is
-- excluding OR and AND) and returns True if so, False otherwise, it does
-- no other processing.
- procedure Process_Decisions (N : Node_Id; T : Character);
+ procedure Process_Decisions
+ (N : Node_Id;
+ T : Character;
+ Pragma_Sloc : Source_Ptr);
-- If N is Empty, has no effect. Otherwise scans the tree for the node N,
-- to output any decisions it contains. T is one of IEGPWX (for context of
-- expression: if/exit when/entry guard/pragma/while/expression). If T is
@@ -109,7 +112,10 @@ package body Par_SCO is
-- decision is always present (at the very least a simple decision is
-- present at the top level).
- procedure Process_Decisions (L : List_Id; T : Character);
+ procedure Process_Decisions
+ (L : List_Id;
+ T : Character;
+ Pragma_Sloc : Source_Ptr);
-- Calls above procedure for each element of the list L
procedure Set_Table_Entry
@@ -316,13 +322,17 @@ package body Par_SCO is
-- Version taking a list
- procedure Process_Decisions (L : List_Id; T : Character) is
+ procedure Process_Decisions
+ (L : List_Id;
+ T : Character;
+ Pragma_Sloc : Source_Ptr)
+ is
N : Node_Id;
begin
if L /= No_List then
N := First (L);
while Present (N) loop
- Process_Decisions (N, T);
+ Process_Decisions (N, T, Pragma_Sloc);
Next (N);
end loop;
end if;
@@ -330,11 +340,14 @@ package body Par_SCO is
-- Version taking a node
- Pragma_Sloc : Source_Ptr := No_Location;
- -- While processing decisions within a pragma Assert/Debug/PPC, this is set
- -- to the sloc of the pragma.
+ Current_Pragma_Sloc : Source_Ptr := No_Location;
+ -- While processing a pragma, this is set to the sloc of the N_Pragma node
- procedure Process_Decisions (N : Node_Id; T : Character) is
+ procedure Process_Decisions
+ (N : Node_Id;
+ T : Character;
+ Pragma_Sloc : Source_Ptr)
+ is
Mark : Nat;
-- This is used to mark the location of a decision sequence in the SCO
-- table. We use it for backing out a simple decision in an expression
@@ -466,14 +479,6 @@ package body Par_SCO is
Loc := Sloc (Parent (Parent (N)));
- if T = 'P' then
-
- -- Record sloc of pragma (pragmas don't nest)
-
- pragma Assert (Pragma_Sloc = No_Location);
- Pragma_Sloc := Loc;
- end if;
-
when 'X' =>
-- For an expression, no Sloc
@@ -493,17 +498,6 @@ package body Par_SCO is
To => No_Location,
Last => False,
Pragma_Sloc => Pragma_Sloc);
-
- if T = 'P' then
-
- -- For pragmas we also must make an entry in the hash table for
- -- later access by Set_SCO_Pragma_Enabled. We set the pragma as
- -- disabled now, the call will change C2 to 'e' to enable the
- -- pragma header entry.
-
- SCO_Table.Table (SCO_Table.Last).C2 := 'd';
- Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
- end if;
end Output_Header;
------------------------------
@@ -521,7 +515,7 @@ package body Par_SCO is
Process_Decision_Operand (Right_Opnd (N));
else
- Process_Decisions (N, 'X');
+ Process_Decisions (N, 'X', Pragma_Sloc);
end if;
end Process_Decision_Operand;
@@ -595,9 +589,9 @@ package body Par_SCO is
Thnx : constant Node_Id := Next (Cond);
Elsx : constant Node_Id := Next (Thnx);
begin
- Process_Decisions (Cond, 'I');
- Process_Decisions (Thnx, 'X');
- Process_Decisions (Elsx, 'X');
+ Process_Decisions (Cond, 'I', Pragma_Sloc);
+ Process_Decisions (Thnx, 'X', Pragma_Sloc);
+ Process_Decisions (Elsx, 'X', Pragma_Sloc);
return Skip;
end;
@@ -635,12 +629,6 @@ package body Par_SCO is
end if;
Traverse (N);
-
- -- Reset Pragma_Sloc after full subtree traversal
-
- if T = 'P' then
- Pragma_Sloc := No_Location;
- end if;
end Process_Decisions;
-----------
@@ -771,8 +759,12 @@ package body Par_SCO is
-- disabled.
if Index /= 0 then
- pragma Assert (SCO_Table.Table (Index).C1 = 'P');
- return SCO_Table.Table (Index).C2 = 'd';
+ declare
+ T : SCO_Table_Entry renames SCO_Table.Table (Index);
+ begin
+ pragma Assert (T.C1 = 'S' or else T.C1 = 's');
+ return T.C2 = 'p';
+ end;
else
return False;
@@ -899,8 +891,17 @@ package body Par_SCO is
-- The test here for zero is to deal with possible previous errors
if Index /= 0 then
- pragma Assert (SCO_Table.Table (Index).C1 = 'P');
- SCO_Table.Table (Index).C2 := 'e';
+ declare
+ T : SCO_Table_Entry renames SCO_Table.Table (Index);
+ begin
+ -- Called multiple times for the same sloc (need to allow for
+ -- C2 = 'P') ???
+
+ pragma Assert ((T.C1 = 'S' or else T.C1 = 's')
+ and then
+ (T.C2 = 'p' or else T.C2 = 'P'));
+ T.C2 := 'P';
+ end;
end if;
end Set_SCO_Pragma_Enabled;
@@ -987,12 +988,14 @@ package body Par_SCO is
Nod : Node_Id;
Lst : List_Id;
Typ : Character;
+ Plo : Source_Ptr;
end record;
-- Used to store a single entry in the following table. Nod is the node to
-- be searched for decisions for the case of Process_Decisions_Defer with a
-- node argument (with Lst set to No_List. Lst is the list to be searched
-- for decisions for the case of Process_Decisions_Defer with a List
- -- argument (in which case Nod is set to Empty).
+ -- argument (in which case Nod is set to Empty). Plo is the sloc of the
+ -- enclosing pragma, if any.
package SD is new Table.Table (
Table_Component_Type => SD_Entry,
@@ -1077,11 +1080,15 @@ package body Par_SCO is
SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location;
begin
- -- For the statement SCO for a pragma, set Pragma_Sloc so that
- -- the SCO can be omitted if the pragma is disabled.
+ -- For the statement SCO for a pragma controlled by
+ -- Set_SCO_Pragma_Enable, set Pragma_Sloc so that the SCO (and
+ -- those of any nested decision) is emitted only if the pragma
+ -- is enabled.
- if SCE.Typ = 'P' then
+ if SCE.Typ = 'p' then
Pragma_Sloc := SCE.From;
+ Condition_Pragma_Hash_Table.Set
+ (Pragma_Sloc, SCO_Table.Last + 1);
end if;
Set_Table_Entry
@@ -1105,9 +1112,9 @@ package body Par_SCO is
SDE : SD_Entry renames SD.Table (J);
begin
if Present (SDE.Nod) then
- Process_Decisions (SDE.Nod, SDE.Typ);
+ Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
else
- Process_Decisions (SDE.Lst, SDE.Typ);
+ Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
end if;
end;
end loop;
@@ -1148,12 +1155,12 @@ package body Par_SCO is
procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
begin
- SD.Append ((N, No_List, T));
+ 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));
+ SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
-- Start of processing for Traverse_Declarations_Or_Statements
@@ -1391,42 +1398,70 @@ package body Par_SCO is
-- Pragma
when N_Pragma =>
- Extend_Statement_Sequence (N, 'P');
+
+ -- Record sloc of pragma (pragmas don't nest)
+
+ pragma Assert (Current_Pragma_Sloc = No_Location);
+ Current_Pragma_Sloc := Sloc (N);
-- Processing depends on the kind of pragma
- case Pragma_Name (N) is
- when Name_Assert |
- Name_Check |
- Name_Precondition |
- Name_Postcondition =>
-
- -- For Assert/Check/Precondition/Postcondition, we
- -- must generate a P entry for the decision. Note that
- -- this is done unconditionally at this stage. Output
- -- for disabled pragmas is suppressed later on, when
- -- we output the decision line in Put_SCOs.
-
- declare
- Nam : constant Name_Id :=
- Chars (Pragma_Identifier (N));
- Arg : Node_Id :=
- First (Pragma_Argument_Associations (N));
-
- begin
+ declare
+ Nam : constant Name_Id := Pragma_Name (N);
+ Arg : Node_Id := First (Pragma_Argument_Associations (N));
+ Typ : Character;
+
+ begin
+ case Nam is
+ when Name_Assert |
+ Name_Check |
+ Name_Precondition |
+ Name_Postcondition =>
+
+ -- For Assert/Check/Precondition/Postcondition, we
+ -- must generate a P entry for the decision. Note
+ -- that this is done unconditionally at this stage.
+ -- Output for disabled pragmas is suppressed later
+ -- on, when we output the decision line in
+ -- Put_SCOs, depending on marker sets by
+ -- Set_SCO_Pragma_Disabled.
+
if Nam = Name_Check then
Next (Arg);
end if;
Process_Decisions_Defer (Expression (Arg), 'P');
- end;
+ Typ := 'p';
- -- For all other pragmas, we generate decision entries
- -- for any embedded expressions.
+ when Name_Debug =>
+ if Present (Arg) and then Present (Next (Arg)) then
- when others =>
- Process_Decisions_Defer (N, 'X');
- end case;
+ -- Case of a dyadic pragma Debug: first argument
+ -- is a P decision, any nested decision in the
+ -- second argument is an X decision.
+
+ Process_Decisions_Defer (Expression (Arg), 'P');
+ Next (Arg);
+ end if;
+
+ Process_Decisions_Defer (Expression (Arg), 'X');
+ Typ := 'p';
+
+ -- For all other pragmas, we generate decision entries
+ -- for any embedded expressions, and the pragma is
+ -- never disabled.
+
+ when others =>
+ Process_Decisions_Defer (N, 'X');
+ Typ := 'P';
+ end case;
+
+ -- Add statement SCO
+
+ Extend_Statement_Sequence (N, Typ);
+
+ Current_Pragma_Sloc := No_Location;
+ end;
-- Object declaration. Ignored if Prev_Ids is set, since the
-- parser generates multiple instances of the whole declaration
@@ -1512,7 +1547,7 @@ package body Par_SCO is
-- Now output any embedded decisions
- Process_Decisions (N, 'X');
+ Process_Decisions (N, 'X', No_Location);
end Traverse_Generic_Instantiation;
------------------------------------------
@@ -1521,7 +1556,7 @@ package body Par_SCO is
procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
begin
- Process_Decisions (Generic_Formal_Declarations (N), 'X');
+ Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
Traverse_Package_Declaration (N);
end Traverse_Generic_Package_Declaration;