OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r177442
This commit is contained in:
Arnaud Charlet 2011-08-05 16:18:09 +02:00
parent bb3c784c7d
commit 44a10091cf
14 changed files with 368 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
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.
2011-08-05 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, gnatcmd.adb, switch-c.adb, exp_attr.adb, make.adb,

72
gcc/ada/exp_disp.adb
View File

@ -7722,11 +7722,59 @@ package body Exp_Disp is
procedure Set_All_DT_Position (Typ : Entity_Id) is
function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
-- Returns True if Prim is located in the dispatch table of
-- predefined primitives
procedure Validate_Position (Prim : Entity_Id);
-- Check that the position assigned to Prim is completely safe
-- (it has not been assigned to a previously defined primitive
-- operation of Typ)
------------------------
-- In_Predef_Prims_DT --
------------------------
function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
E : Entity_Id;
begin
-- Predefined primitives
if Is_Predefined_Dispatching_Operation (Prim) then
return True;
-- Renamings of predefined primitives
elsif Present (Alias (Prim))
and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
then
if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
return True;
-- User-defined renamings of predefined equality have their own
-- slot in the primary dispatch table
else
E := Prim;
while Present (Alias (E)) loop
if Comes_From_Source (E) then
return False;
end if;
E := Alias (E);
end loop;
return not Comes_From_Source (E);
end if;
-- User-defined primitives
else
return False;
end if;
end In_Predef_Prims_DT;
-----------------------
-- Validate_Position --
-----------------------
@ -7850,10 +7898,7 @@ package body Exp_Disp is
-- Predefined primitives have a separate dispatch table
if not (Is_Predefined_Dispatching_Operation (Prim)
or else
Is_Predefined_Dispatching_Alias (Prim))
then
if not In_Predef_Prims_DT (Prim) then
Count_Prim := Count_Prim + 1;
end if;
@ -7978,12 +8023,14 @@ package body Exp_Disp is
-- Predefined primitives have a separate table and all its
-- entries are at predefined fixed positions.
if Is_Predefined_Dispatching_Operation (Prim) then
Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
if In_Predef_Prims_DT (Prim) then
if Is_Predefined_Dispatching_Operation (Prim) then
Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
elsif Is_Predefined_Dispatching_Alias (Prim) then
Set_DT_Position (Prim,
Default_Prim_Op_Position (Ultimate_Alias (Prim)));
else pragma Assert (Present (Alias (Prim)));
Set_DT_Position (Prim,
Default_Prim_Op_Position (Ultimate_Alias (Prim)));
end if;
-- Overriding primitives of ancestor abstract interfaces
@ -8124,8 +8171,7 @@ package body Exp_Disp is
-- Calculate real size of the dispatch table
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
if not In_Predef_Prims_DT (Prim)
and then UI_To_Int (DT_Position (Prim)) > DT_Length
then
DT_Length := UI_To_Int (DT_Position (Prim));
@ -8134,8 +8180,8 @@ package body Exp_Disp is
-- Ensure that the assigned position to non-predefined
-- dispatching operations in the dispatch table is correct.
if not (Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim))
if not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Alias (Prim)
then
Validate_Position (Prim);
end if;

12
gcc/ada/get_scos.adb
View File

@ -315,7 +315,6 @@ begin
declare
Loc : Source_Location;
C2v : Character;
begin
-- Acquire location information
@ -326,18 +325,9 @@ begin
Get_Source_Location (Loc);
end if;
-- C2 is a space except for pragmas where it is 'e' since
-- clearly the pragma is enabled if it was written out.
if C = 'P' then
C2v := 'e';
else
C2v := ' ';
end if;
Add_SCO
(C1 => Dtyp,
C2 => C2v,
C2 => ' ',
From => Loc,
To => No_Source_Location,
Last => False);

189
gcc/ada/par_sco.adb
View File

@ -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 =>
declare
Nam : constant Name_Id := Pragma_Name (N);
Arg : Node_Id := First (Pragma_Argument_Associations (N));
Typ : Character;
-- 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.
begin
case Nam is
when Name_Assert |
Name_Check |
Name_Precondition |
Name_Postcondition =>
declare
Nam : constant Name_Id :=
Chars (Pragma_Identifier (N));
Arg : Node_Id :=
First (Pragma_Argument_Associations (N));
-- 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.
begin
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;

6
gcc/ada/par_sco.ads
View File

@ -50,9 +50,9 @@ package Par_SCO is
-- original tree associated with Cond.
procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr);
-- This procedure is called from Sem_Prag when a pragma is enabled (i.e.
-- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma
-- node. This is used to enable the corresponding SCO table entry. Note
-- This procedure is called from Sem_Prag when a pragma is disabled (i.e.
-- when the Pragma_Enabled flag is unset). Loc is the Sloc of the N_Pragma
-- node. This is used to disable the corresponding SCO table entry. Note
-- that we use the Sloc as the key here, since in the generic case, the
-- analysis is on a copy of the node, which is different from the node
-- seen by Par_SCO in the parse tree (but the Sloc values are the same).

12
gcc/ada/put_scos.adb
View File

@ -107,9 +107,8 @@ begin
Ctr := 0;
Continuation := False;
loop
if SCO_Table.Table (Start).C2 = 'P'
and then SCO_Pragma_Disabled
(SCO_Table.Table (Start).Pragma_Sloc)
if SCO_Pragma_Disabled
(SCO_Table.Table (Start).Pragma_Sloc)
then
goto Next_Statement;
end if;
@ -160,13 +159,10 @@ begin
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Start := Start + 1;
-- For disabled pragma, or nested decision nested, skip
-- For disabled pragma, or nested decision therein, skip
-- decision output.
if (T.C1 = 'P' and then T.C2 = 'd')
or else
SCO_Pragma_Disabled (T.Pragma_Sloc)
then
if SCO_Pragma_Disabled (T.Pragma_Sloc) then
while not SCO_Table.Table (Start).Last loop
Start := Start + 1;
end loop;

30
gcc/ada/scos.ads
View File

@ -152,6 +152,7 @@ package SCOs is
-- E EXIT statement
-- F FOR loop statement (from FOR through end of iteration scheme)
-- I IF statement (from IF through end of condition)
-- p disabled PRAGMA
-- P PRAGMA
-- R extended RETURN statement
-- W WHILE loop statement (from WHILE through end of condition)
@ -194,12 +195,12 @@ package SCOs is
-- Decisions are either simple or complex. A simple decision is a top
-- level boolean expression that has only one condition and that occurs
-- in the context of a control structure in the source program, including
-- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or
-- Post_Condition pragma. For pragmas, decision SCOs are generated only
-- if the corresponding pragma is enabled. Note that a top level boolean
-- expression with only one condition that occurs in any other context,
-- for example as right hand side of an assignment, is not considered to
-- be a (simple) decision.
-- WHILE, IF, EXIT WHEN, or immediately within an Assert, Check,
-- Pre_Condition or Post_Condition pragma, or as the first argument of a
-- dyadic pragma Debug. Note that a top level boolean expression with
-- only one condition that occurs in any other context, for example as
-- right hand side of an assignment, is not considered to be a (simple)
-- decision.
-- A complex decision is a top level boolean expression that has more
-- than one condition. A complex decision may occur in any boolean
@ -336,6 +337,10 @@ package SCOs is
-- entries appear in one logical statement sequence, continuation lines
-- are marked by Cc and appear immediately after the CC line.
-- Disabled pragmas
-- No SCO is generated for disabled pragmas.
---------------------------------------------------------------------
-- Internal table used to store Source Coverage Obligations (SCOs) --
---------------------------------------------------------------------
@ -392,7 +397,7 @@ package SCOs is
-- Decision (PRAGMA)
-- C1 = 'P'
-- C2 = 'e'/'d' for enabled/disabled
-- C2 = ' '
-- From = PRAGMA token
-- To = No_Source_Location
-- Last = unused
@ -400,14 +405,11 @@ package SCOs is
-- Note: when the parse tree is first scanned, we unconditionally build
-- a pragma decision entry for any decision in a pragma (here as always
-- in SCO contexts, the only pragmas with decisions are Assert, Check,
-- Precondition and Postcondition), and we mark the pragma as disabled.
-- dyadic Debug, Precondition and Postcondition).
--
-- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to
-- mark the SCO decision table entry as enabled (C2 set to 'e'). Then
-- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'.
--
-- When we read SCOs from an ALI file (in Get_SCOs), we always set C2
-- to 'e', since clearly the pragma is enabled if it was written out.
-- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled
-- marks the statement SCO table entry as enaabled (C1 changed from 'p'
-- to 'P') to cause the entry to be emitted in Put_SCOs.
-- Decision (Expression)
-- C1 = 'X'

8
gcc/ada/sem_ch3.adb
View File

@ -4215,6 +4215,8 @@ package body Sem_Ch3 is
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Implicit_Dereference
(Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
@ -4248,6 +4250,8 @@ package body Sem_Ch3 is
Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Implicit_Dereference
(Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
@ -7875,6 +7879,8 @@ package body Sem_Ch3 is
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
Set_Has_Implicit_Dereference
(Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
@ -8586,6 +8592,8 @@ package body Sem_Ch3 is
Set_First_Entity (Def_Id, First_Entity (T));
Set_Last_Entity (Def_Id, Last_Entity (T));
Set_Has_Implicit_Dereference
(Def_Id, Has_Implicit_Dereference (T));
-- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must

35
gcc/ada/sem_ch4.adb
View File

@ -301,7 +301,24 @@ package body Sem_Ch4 is
Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd);
else
elsif Ada_Version >= Ada_2012 then
declare
It : Interp;
I : Interp_Index;
begin
Get_First_Interp (Opnd, I, It);
while Present (It.Nam) loop
if Has_Implicit_Dereference (It.Typ) then
Error_Msg_N
("can be interpreted as implicit dereference", Opnd);
return;
end if;
Get_Next_Interp (I, It);
end loop;
end;
return;
end if;
@ -2068,6 +2085,7 @@ package body Sem_Ch4 is
end loop;
Set_Etype (N, Component_Type (Array_Type));
Check_Implicit_Dereference (N, Etype (N));
if Present (Index) then
Error_Msg_N
@ -2164,9 +2182,13 @@ package body Sem_Ch4 is
end loop;
if Found and then No (Index) and then No (Exp) then
Add_One_Interp (N,
Etype (Component_Type (Typ)),
Etype (Component_Type (Typ)));
declare
CT : constant Entity_Id :=
Base_Type (Component_Type (Typ));
begin
Add_One_Interp (N, CT, CT);
Check_Implicit_Dereference (N, CT);
end;
end if;
end if;
@ -2644,6 +2666,7 @@ package body Sem_Ch4 is
procedure Indicate_Name_And_Type is
begin
Add_One_Interp (N, Nam, Etype (Nam));
Check_Implicit_Dereference (N, Etype (Nam));
Success := True;
-- If the prefix of the call is a name, indicate the entity
@ -3133,6 +3156,7 @@ package body Sem_Ch4 is
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
Check_Implicit_Dereference (N, Etype (Comp));
-- This also specifies a candidate to resolve the name.
-- Further overloading will be resolved from context.
@ -3740,6 +3764,7 @@ package body Sem_Ch4 is
New_Occurrence_Of (Comp, Sloc (N)));
Set_Original_Discriminant (Selector_Name (N), Comp);
Set_Etype (N, Etype (Comp));
Check_Implicit_Dereference (N, Etype (Comp));
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
@ -3876,6 +3901,7 @@ package body Sem_Ch4 is
Set_Etype (N, Etype (Comp));
end if;
Check_Implicit_Dereference (N, Etype (N));
return;
end if;
@ -3941,6 +3967,7 @@ package body Sem_Ch4 is
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
Check_Implicit_Dereference (N, Etype (N));
if Is_Generic_Type (Prefix_Type)
or else Is_Generic_Type (Root_Type (Prefix_Type))

1
gcc/ada/sem_ch8.adb
View File

@ -4818,6 +4818,7 @@ package body Sem_Ch8 is
end if;
Set_Entity_Or_Discriminal (N, E);
Check_Implicit_Dereference (N, Etype (E));
end if;
end;
end Find_Direct_Name;

6
gcc/ada/sem_prag.adb
View File

@ -1794,7 +1794,7 @@ package body Sem_Prag is
(Get_Pragma_Arg (Arg2), Standard_String);
end if;
-- Record if pragma is enabled
-- Record if pragma is disabled
if Check_Enabled (Pname) then
Set_SCO_Pragma_Enabled (Loc);
@ -7604,6 +7604,10 @@ package body Sem_Prag is
(Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
Loc);
if Debug_Pragmas_Enabled then
Set_SCO_Pragma_Enabled (Loc);
end if;
if Arg_Count = 2 then
Cond :=
Make_And_Then (Loc,

49
gcc/ada/sem_res.adb
View File

@ -1753,6 +1753,15 @@ package body Sem_Res is
It1 : Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
-- AI05-139 : names with implicit dereference. If the expression N is a
-- reference type and the context imposes the corresponding designated
-- type, convert N into N.Disc.all. Such expressions are always over-
-- loaded with both interpretations, and the dereference interpretation
-- carries the name of the reference discriminant.
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- Determine whether a node comes from a predefined library unit or
-- Standard.
@ -1768,6 +1777,30 @@ package body Sem_Res is
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
--------------------------------
-- Build_Explicit_Dereference --
--------------------------------
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Expr);
begin
Set_Is_Overloaded (Expr, False);
Rewrite (Expr,
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expr),
Selector_Name =>
New_Occurrence_Of (Disc, Loc))));
Set_Etype (Prefix (Expr), Etype (Disc));
Set_Etype (Expr, Typ);
end Build_Explicit_Dereference;
------------------------------------
-- Comes_From_Predefined_Lib_Unit --
-------------------------------------
@ -2279,6 +2312,22 @@ package body Sem_Res is
elsif Nkind (N) = N_Conditional_Expression then
Set_Etype (N, Expr_Type);
-- AI05-0139-2 : expression is overloaded because
-- type has implicit dereference. If type matches
-- context, no implicit dereference is involved.
elsif Has_Implicit_Dereference (Expr_Type) then
Set_Etype (N, Expr_Type);
Set_Is_Overloaded (N, False);
exit Interp_Loop;
elsif Is_Overloaded (N)
and then Present (It.Nam)
and then Ekind (It.Nam) = E_Discriminant
and then Has_Implicit_Dereference (It.Nam)
then
Build_Explicit_Dereference (N, It.Nam);
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node), or call
-- with a name that is an explicit dereference, there is

37
gcc/ada/sem_util.adb
View File

@ -1104,6 +1104,43 @@ package body Sem_Util is
end if;
end Cannot_Raise_Constraint_Error;
--------------------------------
-- Check_Implicit_Dereference --
--------------------------------
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id)
is
Disc : Entity_Id;
Desig : Entity_Id;
begin
if Ada_Version < Ada_2012
or else not Has_Implicit_Dereference (Base_Type (Typ))
then
return;
elsif not Comes_From_Source (Nam) then
return;
elsif Is_Entity_Name (Nam)
and then Is_Type (Entity (Nam))
then
null;
else
Disc := First_Discriminant (Typ);
while Present (Disc) loop
if Has_Implicit_Dereference (Disc) then
Desig := Designated_Type (Etype (Disc));
Add_One_Interp (Nam, Disc, Desig);
exit;
end if;
Next_Discriminant (Disc);
end loop;
end if;
end Check_Implicit_Dereference;
---------------------------------------
-- Check_Later_Vs_Basic_Declarations --
---------------------------------------

5
gcc/ada/sem_util.ads
View File

@ -147,6 +147,11 @@ package Sem_Util is
-- not necessarily mean that CE could be raised, but a response of True
-- means that for sure CE cannot be raised.
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
-- AI05-139-2 : accessors and iterators for containers. This procedure
-- checks whether T is a reference type, and if so it adds an interprettion
-- to Expr whose type is the designated type of the reference_discriminant.
procedure Check_Later_Vs_Basic_Declarations
(Decls : List_Id;
During_Parsing : Boolean);