From 5a153b2787e167cb9f065e6fd91424b0475b2790 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 21 Jun 2010 15:35:58 +0200 Subject: [PATCH] [multiple changes] 2010-06-21 Thomas Quinot * 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 * s-regpat.adb (Compile): Fix handling of big patterns. 2010-06-21 Robert Dewar * a-tifiio.adb: Minor reformatting. From-SVN: r161076 --- gcc/ada/ChangeLog | 26 +++++++ gcc/ada/a-tifiio.adb | 2 +- gcc/ada/checks.adb | 161 +++++++++++-------------------------------- gcc/ada/s-regpat.adb | 10 +-- gcc/ada/sem_attr.adb | 37 ++++++++++ gcc/ada/sem_ch9.adb | 70 +------------------ gcc/ada/sem_res.adb | 3 +- gcc/ada/sem_util.adb | 31 +++++++++ gcc/ada/sem_util.ads | 16 +++-- 9 files changed, 154 insertions(+), 202 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 71627b22ca4..30a6f602dbf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2010-06-21 Thomas Quinot + + * 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 + + * s-regpat.adb (Compile): Fix handling of big patterns. + +2010-06-21 Robert Dewar + + * a-tifiio.adb: Minor reformatting. + 2010-06-21 Pascal Obry * prj-nmsc.adb (Search_Directories): Use the non-translated directory diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index 28267ad85fc..82aeb8a83e6 100644 --- a/gcc/ada/a-tifiio.adb +++ b/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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 0f18fbc5823..ebe6e5ade69 100644 --- a/gcc/ada/checks.adb +++ b/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 diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index 517256aff77..187d8fb992c 100755 --- a/gcc/ada/s-regpat.adb +++ b/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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bfd434373b2..73e77e3d738 100644 --- a/gcc/ada/sem_attr.adb +++ b/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; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index df7d50acc66..dd23fc0ba97 100644 --- a/gcc/ada/sem_ch9.adb +++ b/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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 86ee044c40d..418d57f4893 100644 --- a/gcc/ada/sem_res.adb +++ b/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 := diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9fc997fd5d9..262a890c8ab 100644 --- a/gcc/ada/sem_util.adb +++ b/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 -- ------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 806cbcf8c87..2d786a4d94c 100644 --- a/gcc/ada/sem_util.ads +++ b/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 -- 2.30.2