diff options
Diffstat (limited to 'gcc/ada/exp_util.adb')
| -rw-r--r-- | gcc/ada/exp_util.adb | 257 |
1 files changed, 222 insertions, 35 deletions
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 82f3fcfc201..12fea51a197 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -336,7 +336,7 @@ package body Exp_Util is -- component, whose prefix is the outer variable of the array type. -- The n-dimensional array type has known indices Index, Index2... -- Id_Ref is an indexed component form created by the enclosing init proc. - -- Its successive indices are Val1, Val2,.. which are the loop variables + -- Its successive indices are Val1, Val2, ... which are the loop variables -- in the loops that call the individual task init proc on each component. -- The generated function has the following structure: @@ -962,9 +962,16 @@ package body Exp_Util is if Has_Entries (Typ) or else Has_Interrupt_Handler (Typ) or else (Has_Attach_Handler (Typ) - and then not Restricted_Profile) - or else (Ada_Version >= Ada_05 - and then Present (Interface_List (Parent (Typ)))) + and then not Restricted_Profile) + + -- A protected type without entries that covers an interface and + -- overrides the abstract routines with protected procedures is + -- considered equivalent to a protected type with entries in the + -- context of dispatching select statements. It is sufficent to + -- check for the presence of an interface list in the declaration + -- node to recognize this case. + + or else Present (Interface_List (Parent (Typ))) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False @@ -1814,6 +1821,34 @@ package body Exp_Util is return Node (Prim); end Find_Prim_Op; + ---------------------------- + -- Find_Protection_Object -- + ---------------------------- + + function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is + S : Entity_Id; + + begin + S := Scop; + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Present (Protection_Object (S)) + then + return Protection_Object (S); + end if; + + S := Scope (S); + end loop; + + -- If we do not find a Protection object in the scope chain, then + -- something has gone wrong, most likely the object was never created. + + raise Program_Error; + end Find_Protection_Object; + ---------------------- -- Force_Evaluation -- ---------------------- @@ -2292,13 +2327,14 @@ package body Exp_Util is return; end if; - -- Ignore insert of actions from inside default expression in the - -- special preliminary analyze mode. Any insertions at this point - -- have no relevance, since we are only doing the analyze to freeze - -- the types of any static expressions. See section "Handling of - -- Default Expressions" in the spec of package Sem for further details. + -- Ignore insert of actions from inside default expression (or other + -- similar "spec expression") in the special spec-expression analyze + -- mode. Any insertions at this point have no relevance, since we are + -- only doing the analyze to freeze the types of any static expressions. + -- See section "Handling of Default Expressions" in the spec of package + -- Sem for further details. - if In_Default_Expression then + if In_Spec_Expression then return; end if; @@ -3028,6 +3064,10 @@ package body Exp_Util is Get_Name_String (Chars (E)); + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homgeneous binary operator that returns Boolean. + if Name_Len > TSS_Name_Type'Last then TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); @@ -3441,6 +3481,40 @@ package body Exp_Util is and then Etype (Full_View (T)) /= T); end Is_Untagged_Derivation; + --------------------------- + -- Is_Volatile_Reference -- + --------------------------- + + function Is_Volatile_Reference (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Has_Etype + and then Present (Etype (N)) + and then Treat_As_Volatile (Etype (N)) + then + return True; + + elsif Is_Entity_Name (N) then + return Treat_As_Volatile (Entity (N)); + + elsif Nkind (N) = N_Slice then + return Is_Volatile_Reference (Prefix (N)); + + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if (Is_Entity_Name (Prefix (N)) + and then Has_Volatile_Components (Entity (Prefix (N)))) + or else (Present (Etype (Prefix (N))) + and then Has_Volatile_Components (Etype (Prefix (N)))) + then + return True; + else + return Is_Volatile_Reference (Prefix (N)); + end if; + + else + return False; + end if; + end Is_Volatile_Reference; + -------------------- -- Kill_Dead_Code -- -------------------- @@ -4257,9 +4331,15 @@ package body Exp_Util is end if; end; - -- If we have neither a record nor array component, it means that we - -- have fallen off the top testing prefixes recursively, and we now - -- have a stand alone object, where we don't have a problem. + -- For a slice, test the prefix, if that is possibly misaligned, + -- then for sure the slice is! + + when N_Slice => + return Possible_Bit_Aligned_Component (Prefix (N)); + + -- If we have none of the above, it means that we have fallen off the + -- top testing prefixes recursively, and we now have a stand alone + -- object, where we don't have a problem. when others => return False; @@ -4375,7 +4455,7 @@ package body Exp_Util is -- hand, if we do not consider them to be side effect free, then -- we get some awkward expansions in -gnato mode, resulting in -- code insertions at a point where we do not have a clear model - -- for performing the insertions. See 4908-002/comment for details. + -- for performing the insertions. -- Special handling for entity names @@ -4399,14 +4479,13 @@ package body Exp_Util is return False; -- Variables are considered to be a side effect if Variable_Ref - -- is set or if we have a volatile variable and Name_Req is off. + -- is set or if we have a volatile reference and Name_Req is off. -- If Name_Req is True then we can't help returning a name which -- effectively allows multiple references in any case. elsif Is_Variable (N) then return not Variable_Ref - and then (not Treat_As_Volatile (Entity (N)) - or else Name_Req); + and then (not Is_Volatile_Reference (N) or else Name_Req); -- Any other entity (e.g. a subtype name) is definitely side -- effect free. @@ -4631,17 +4710,16 @@ package body Exp_Util is Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function or operator call. And if we have a - -- volatile variable and Nam_Req is not set (see comments above for - -- Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference or an + -- operator. And if we have a volatile reference and Name_Req is not + -- set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call + or else Nkind (Exp) = N_Attribute_Reference or else Nkind (Exp) in N_Op - or else (not Name_Req - and then Is_Entity_Name (Exp) - and then Treat_As_Volatile (Entity (Exp)))) + or else (not Name_Req and then Is_Volatile_Reference (Exp))) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Set_Etype (Def_Id, Exp_Type); @@ -4686,9 +4764,9 @@ package body Exp_Util is -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several - -- circumstances: for change of representations, and also when this - -- is a view conversion to a smaller object, where gigi can end up - -- creating its own temporary of the wrong size. + -- circumstances: for change of representations, and also when this is + -- a view conversion to a smaller object, where gigi can end up creating + -- its own temporary of the wrong size. elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); @@ -4732,14 +4810,12 @@ package body Exp_Util is end if; -- For expressions that denote objects, we can use a renaming scheme. - -- We skip using this if we have a volatile variable and we do not - -- have Nam_Req set true (see comments above for Side_Effect_Free). + -- We skip using this if we have a volatile reference and we do not + -- have Name_Req set true (see comments above for Side_Effect_Free). elsif Is_Object_Reference (Exp) and then Nkind (Exp) /= N_Function_Call - and then (Name_Req - or else not Is_Entity_Name (Exp) - or else not Treat_As_Volatile (Entity (Exp))) + and then (Name_Req or else not Is_Volatile_Reference (Exp)) then Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); @@ -4778,7 +4854,7 @@ package body Exp_Util is -- If this is a packed reference, or a selected component with a -- non-standard representation, a reference to the temporary will -- be replaced by a copy of the original expression (see - -- exp_ch2.Expand_Renaming). Otherwise the temporary must be + -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line -- by the expression it renames, which would defeat the purpose of -- removing the side-effect. @@ -4795,6 +4871,36 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else + -- Special processing for function calls that return a task. We need + -- to build a declaration that will enable build-in-place expansion + -- of the call. + + -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have + -- to accommodate functions returning limited objects by reference. + + if Nkind (Exp) = N_Function_Call + and then Is_Task_Type (Etype (Exp)) + and then Ada_Version >= Ada_05 + then + declare + Obj : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('F')); + Decl : Node_Id; + + begin + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Expression => Relocate_Node (Exp)); + Insert_Action (Exp, Decl); + Set_Etype (Obj, Exp_Type); + Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); + return; + end; + end if; + Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Ptr_Typ_Decl := @@ -5202,9 +5308,9 @@ package body Exp_Util is Analyze (Asn); - -- Kill current value indication. This is necessary because - -- the tests of this flag are inserted out of sequence and must - -- not pick up bogus indications of the wrong constant value. + -- Kill current value indication. This is necessary because the + -- tests of this flag are inserted out of sequence and must not + -- pick up bogus indications of the wrong constant value. Set_Current_Value (Ent, Empty); end if; @@ -5237,6 +5343,87 @@ package body Exp_Util is end if; end Set_Renamed_Subprogram; + ---------------------------------- + -- Silly_Boolean_Array_Not_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the case where the 'First of the component type is equal to the + -- 'Last of this component type, and if this is the case, we make sure + -- that constraint error is raised. The reason is that the NOT is bound + -- to cause CE in this case, and we will not otherwise catch it. + + -- Believe it or not, this was reported as a bug. Note that nearly + -- always, the test will evaluate statically to False, so the code will + -- be statically removed, and no extra overhead caused. + + procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last)), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Not_Test; + + ---------------------------------- + -- Silly_Boolean_Array_Xor_Test -- + ---------------------------------- + + -- This procedure implements an odd and silly test. We explicitly check + -- for the XOR case where the component type is True .. True, since this + -- will raise constraint error. A special check is required since CE + -- will not be required otherwise (cf Expand_Packed_Not). + + -- No such check is required for AND and OR, since for both these cases + -- False op False = False, and True op True = True. + + procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + CT : constant Entity_Id := Component_Type (T); + BT : constant Entity_Id := Base_Type (CT); + + begin + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_First), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc))), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (CT, Loc), + Attribute_Name => Name_Last), + + Right_Opnd => + Convert_To (BT, + New_Occurrence_Of (Standard_True, Loc)))), + Reason => CE_Range_Check_Failed)); + end Silly_Boolean_Array_Xor_Test; + -------------------------- -- Target_Has_Fixed_Ops -- -------------------------- |