Skip to content

R
riscv-gcc-1
Commit 5a153b27 by Arnaud Charlet
Options

[multiple changes] 

2010-06-21  Thomas Quinot  <quinot@adacore.com>

	* sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb,
	sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to
	extract bounds, to ensure that we get the proper captured values,
	rather than an expression that may have changed value since the point
	where the subtype was elaborated.
	(Find_Body_Discriminal): New utility subprogram to share code between...
	(Eval_Attribute): For the case of a subtype bound that references a
	discriminant of the current concurrent type, insert appropriate
	discriminal reference.
	(Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a
	requeue to an entry in a family in the current task, use corresponding
	body discriminal. 
	(Analyze_Accept_Statement): Rely on expansion of attribute references
	to insert proper discriminal references in range check for entry in
	family.

2010-06-21  Emmanuel Briot  <briot@adacore.com>

	* s-regpat.adb (Compile): Fix handling of big patterns.

2010-06-21  Robert Dewar  <dewar@adacore.com>

	* a-tifiio.adb: Minor reformatting.

From-SVN: r161076
parent 008f6fd3
Showing with 154 additions and 202 deletions
gcc/ada/ChangeLog
2010-06-21 Thomas Quinot <quinot@adacore.com>
* sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb,
sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to
extract bounds, to ensure that we get the proper captured values,
rather than an expression that may have changed value since the point
where the subtype was elaborated.
(Find_Body_Discriminal): New utility subprogram to share code between...
(Eval_Attribute): For the case of a subtype bound that references a
discriminant of the current concurrent type, insert appropriate
discriminal reference.
(Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a
requeue to an entry in a family in the current task, use corresponding
body discriminal.
(Analyze_Accept_Statement): Rely on expansion of attribute references
to insert proper discriminal references in range check for entry in
family.
2010-06-21 Emmanuel Briot <briot@adacore.com>
* s-regpat.adb (Compile): Fix handling of big patterns.
2010-06-21 Robert Dewar <dewar@adacore.com>
* a-tifiio.adb: Minor reformatting.
2010-06-21 Pascal Obry <obry@adacore.com>
* prj-nmsc.adb (Search_Directories): Use the non-translated directory
......
gcc/ada/a-tifiio.adb
......@@ -304,7 +304,7 @@ package body Ada.Text_IO.Fixed_IO is
Fore : Integer;
Aft : Field;
Exp : Field);
-- Actual output function, used internally by all other Put routines
-- Actual output function, used internally by all other Put routines.
-- The formal Fore is an Integer, not a Field, because the routine is
-- also called from the version of Put that performs I/O to a string,
-- where the starting position depends on the size of the String, and
......
gcc/ada/checks.adb
......@@ -6249,7 +6249,8 @@ package body Checks is
-- Expr > Typ'Last
function Get_E_First_Or_Last
(E : Entity_Id;
(Loc : Source_Ptr;
E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id;
-- Returns expression to compute:
......@@ -6320,7 +6321,7 @@ package body Checks is
Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
Get_E_First_Or_Last (Typ, 0, Name_First))),
Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
Right_Opnd =>
Make_Op_Gt (Loc,
......@@ -6330,7 +6331,7 @@ package body Checks is
Right_Opnd =>
Convert_To
(Base_Type (Typ),
Get_E_First_Or_Last (Typ, 0, Name_Last))));
Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
end Discrete_Expr_Cond;
-------------------------
......@@ -6368,7 +6369,8 @@ package body Checks is
Right_Opnd =>
Convert_To
(Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
(Base_Type (Typ),
Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
if Base_Type (Typ) = Typ then
return Left_Opnd;
......@@ -6403,7 +6405,7 @@ package body Checks is
Right_Opnd =>
Convert_To
(Base_Type (Typ),
Get_E_First_Or_Last (Typ, 0, Name_Last)));
Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
end Discrete_Range_Cond;
......@@ -6413,115 +6415,23 @@ package body Checks is
-------------------------
function Get_E_First_Or_Last
(E : Entity_Id;
(Loc : Source_Ptr;
E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id
is
N : Node_Id;
LB : Node_Id;
HB : Node_Id;
Bound : Node_Id;
Exprs : List_Id;
begin
if Is_Array_Type (E) then
N := First_Index (E);
for J in 2 .. Indx loop
Next_Index (N);
end loop;
if Indx > 0 then
Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
else
N := Scalar_Range (E);
Exprs := No_List;
end if;
if Nkind (N) = N_Subtype_Indication then
LB := Low_Bound (Range_Expression (Constraint (N)));
HB := High_Bound (Range_Expression (Constraint (N)));
elsif Is_Entity_Name (N) then
LB := Type_Low_Bound (Etype (N));
HB := Type_High_Bound (Etype (N));
else
LB := Low_Bound (N);
HB := High_Bound (N);
end if;
if Nam = Name_First then
Bound := LB;
else
Bound := HB;
end if;
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Discriminant
then
-- If this is a task discriminant, and we are the body, we must
-- retrieve the corresponding body discriminal. This is another
-- consequence of the early creation of discriminals, and the
-- need to generate constraint checks before their declarations
-- are made visible.
if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
declare
Tsk : constant Entity_Id :=
Corresponding_Concurrent_Type
(Scope (Entity (Bound)));
Disc : Entity_Id;
begin
if In_Open_Scopes (Tsk)
and then Has_Completion (Tsk)
then
-- Find discriminant of original task, and use its
-- current discriminal, which is the renaming within
-- the task body.
Disc := First_Discriminant (Tsk);
while Present (Disc) loop
if Chars (Disc) = Chars (Entity (Bound)) then
Set_Scope (Discriminal (Disc), Tsk);
return New_Occurrence_Of (Discriminal (Disc), Loc);
end if;
Next_Discriminant (Disc);
end loop;
-- That loop should always succeed in finding a matching
-- entry and returning. Fatal error if not.
raise Program_Error;
else
return
New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
end if;
end;
else
return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
end if;
elsif Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_In_Parameter
and then not Inside_Init_Proc
then
return Get_Discriminal (E, Bound);
elsif Nkind (Bound) = N_Integer_Literal then
return Make_Integer_Literal (Loc, Intval (Bound));
-- Case of a bound rewritten to an N_Raise_Constraint_Error node
-- because it is an out-of-range value. Duplicate_Subexpr cannot be
-- called on this node because an N_Raise_Constraint_Error is not
-- side effect free, and we may not assume that we are in the proper
-- context to remove side effects on it at the point of reference.
elsif Nkind (Bound) = N_Raise_Constraint_Error then
return New_Copy_Tree (Bound);
else
return Duplicate_Subexpr_No_Checks (Bound);
end if;
return Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Nam,
Expressions => Exprs);
end Get_E_First_Or_Last;
-----------------
......@@ -6568,13 +6478,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
Left_Opnd =>
Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
Left_Opnd =>
Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_E_Cond;
------------------------
......@@ -6591,12 +6505,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
Left_Opnd =>
Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
Left_Opnd =>
Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_Equal_E_Cond;
------------------
......@@ -6613,13 +6532,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => Get_N_First (Expr, Indx),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
Left_Opnd =>
Get_N_First (Expr, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => Get_N_Last (Expr, Indx),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
Left_Opnd =>
Get_N_Last (Expr, Indx),
Right_Opnd =>
Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
-- Start of processing for Selected_Range_Checks
......
gcc/ada/s-regpat.adb
......@@ -781,7 +781,7 @@ package body System.Regpat is
procedure Link_Operand_Tail (P, Val : Pointer) is
begin
if Program (P) = BRANCH then
if P <= PM.Size and then Program (P) = BRANCH then
Link_Tail (Operand (P), Val);
end if;
end Link_Operand_Tail;
......@@ -796,14 +796,10 @@ package body System.Regpat is
Offset : Pointer;
begin
if Emit_Ptr > PM.Size then
return;
end if;
-- Find last node
Scan := P;
loop
while Scan <= PM.Size loop
Temp := Get_Next (Program, Scan);
exit when Temp = Scan;
Scan := Temp;
......@@ -914,7 +910,7 @@ package body System.Regpat is
Link_Tail (IP, Ender);
if Have_Branch then
if Have_Branch and then Emit_Ptr <= PM.Size then
-- Hook the tails of the branches to the closing node
......
gcc/ada/sem_attr.adb
......@@ -4811,6 +4811,12 @@ package body Sem_Attr is
-- Computes Aft value for current attribute prefix (used by Aft itself
-- and also by Width for computing the Width of a fixed point type).
procedure Check_Concurrent_Discriminant (Bound : Node_Id);
-- If Bound is a reference to a discriminant of a task or protected type
-- occurring within the object's body, rewrite attribute reference into
-- a reference to the corresponding discriminal. Use for the expansion
-- of checks against bounds of entry family index subtypes.
procedure Check_Expressions;
-- In case where the attribute is not foldable, the expressions, if
-- any, of the attribute, are in a non-static context. This procedure
......@@ -4895,6 +4901,33 @@ package body Sem_Attr is
return Result;
end Aft_Value;
-----------------------------------
-- Check_Concurrent_Discriminant --
-----------------------------------
procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
Tsk : Entity_Id;
-- The concurrent (task or protected) type
begin
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Discriminant
and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
then
Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
if In_Open_Scopes (Tsk)
and then Has_Completion (Tsk)
then
-- Find discriminant of original concurrent type, and use
-- its current discriminal, which is the renaming within
-- the task/protected body.
Rewrite (N,
New_Occurrence_Of
(Find_Body_Discriminal (Entity (Bound)), Loc));
end if;
end if;
end Check_Concurrent_Discriminant;
-----------------------
-- Check_Expressions --
-----------------------
......@@ -5982,6 +6015,8 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
else
Check_Concurrent_Discriminant (Lo_Bound);
end if;
end First_Attr;
......@@ -6170,6 +6205,8 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;
end Last;
......
gcc/ada/sem_ch9.adb
......@@ -30,7 +30,6 @@ with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
......@@ -167,73 +166,6 @@ package body Sem_Ch9 is
Kind : Entity_Kind;
Task_Nam : Entity_Id;
-----------------------
-- Actual_Index_Type --
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id;
-- If the bounds of an entry family depend on task discriminants, create
-- a new index type where a discriminant is replaced by the local
-- variable that renames it in the task body.
-----------------------
-- Actual_Index_Type --
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
Typ : constant Entity_Id := Entry_Index_Type (E);
Lo : constant Node_Id := Type_Low_Bound (Typ);
Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If bound is discriminant reference, replace with corresponding
-- local variable of the same name.
-----------------------------
-- Actual_Discriminant_Ref --
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
return Bound;
else
Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
Analyze (Ref);
Resolve (Ref, Typ);
return Ref;
end if;
end Actual_Discriminant_Ref;
-- Start of processing for Actual_Index_Type
begin
if not Has_Discriminants (Task_Nam)
or else (not Is_Entity_Name (Lo)
and then not Is_Entity_Name (Hi))
then
return Entry_Index_Type (E);
else
New_T := Create_Itype (Ekind (Typ), N);
Set_Etype (New_T, Base_Type (Typ));
Set_Size_Info (New_T, Typ);
Set_RM_Size (New_T, RM_Size (Typ));
Set_Scalar_Range (New_T,
Make_Range (Sloc (N),
Low_Bound => Actual_Discriminant_Ref (Lo),
High_Bound => Actual_Discriminant_Ref (Hi)));
return New_T;
end if;
end Actual_Index_Type;
-- Start of processing for Analyze_Accept_Statement
begin
Tasking_Used := True;
......@@ -370,7 +302,7 @@ package body Sem_Ch9 is
Error_Msg_N ("missing entry index in accept for entry family", N);
else
Analyze_And_Resolve (Index, Entry_Index_Type (E));
Apply_Range_Check (Index, Actual_Index_Type (E));
Apply_Range_Check (Index, Entry_Index_Type (E));
end if;
elsif Present (Index) then
......
gcc/ada/sem_res.adb
......@@ -5929,7 +5929,8 @@ package body Sem_Res is
and then In_Open_Scopes (Tsk)
and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
then
return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
return New_Occurrence_Of
(Find_Body_Discriminal (Entity (Bound)), Loc);
else
Ref :=
......
gcc/ada/sem_util.adb
......@@ -3062,6 +3062,37 @@ package body Sem_Util is
Call := Empty;
end Find_Actual;
---------------------------
-- Find_Body_Discriminal --
---------------------------
function Find_Body_Discriminal
(Spec_Discriminant : Entity_Id) return Entity_Id
is
pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
Tsk : constant Entity_Id :=
Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
Disc : Entity_Id;
begin
-- Find discriminant of original concurrent type, and use its current
-- discriminal, which is the renaming within the task/protected body.
Disc := First_Discriminant (Tsk);
while Present (Disc) loop
if Chars (Disc) = Chars (Spec_Discriminant) then
Set_Scope (Discriminal (Disc), Tsk);
return Discriminal (Disc);
end if;
Next_Discriminant (Disc);
end loop;
-- That loop should always succeed in finding a matching entry and
-- returning. Fatal error if not.
raise Program_Error;
end Find_Body_Discriminal;
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
......
gcc/ada/sem_util.ads
......@@ -329,11 +329,11 @@ package Sem_Util is
function Find_Corresponding_Discriminant
(Id : Node_Id;
Typ : Entity_Id) return Entity_Id;
-- Because discriminants may have different names in a generic unit
-- and in an instance, they are resolved positionally when possible.
-- A reference to a discriminant carries the discriminant that it
-- denotes when analyzed. Subsequent uses of this id on a different
-- type denote the discriminant at the same position in this new type.
-- Because discriminants may have different names in a generic unit and in
-- an instance, they are resolved positionally when possible. A reference
-- to a discriminant carries the discriminant that it denotes when
-- analyzed. Subsequent uses of this id on a different type denotes the
-- discriminant at the same position in this new type.
procedure Find_Overlaid_Entity
(N : Node_Id;
......@@ -355,6 +355,12 @@ package Sem_Util is
-- Determine the alternative chosen, so that the code of non-selected
-- alternatives, and the warnings that may apply to them, are removed.
function Find_Body_Discriminal
(Spec_Discriminant : Entity_Id) return Entity_Id;
-- Given a discriminant of the record type that implements a task or
-- protected type, return the discriminal of the corresponding discriminant
-- of the actual concurrent type.
function First_Actual (Node : Node_Id) return Node_Id;
-- Node is an N_Function_Call or N_Procedure_Call_Statement node. The
-- result returned is the first actual parameter in declaration order
......
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