diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19a390e0047a..d33381a46294 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-01-21 Robert Dewar + + * checks.adb, sem_util.ads, sem_ch4.adb: Minor reformatting. + * gcc-interface/Makefile.in: clean up target pairs. + +2014-01-21 Pascal Obry + + * projects.texi: Minor typo fix. + +2014-01-21 Thomas Quinot + + * freeze.adb (Check_Component_Storage_Order): If a record type + has an explicit Scalar_Storage_Order attribute definition clause, + reject any component that itself is of a composite type and does + not have one. + +2014-01-21 Ed Schonberg + + * sem_ch10.adb (Generate_Parent_Reference): Make public so it + can be used to generate proper cross-reference information for + the parent units of proper bodies. + +2014-01-21 Thomas Quinot + + * exp_pakd.adb (Expand_Packed_Element_Set, + Expand_Packed_Element_Reference): No byte swapping required in + the front-end for the case of a reverse storage order array, + as this is now handled uniformly in the back-end. However we + still need to swap back an extracted element if it is itself a + nested composite with reverse storage order. + 2014-01-21 Hristian Kirtchev * sem_prag.adb (Analyze_External_Property): Add processing for "others". diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f49605502cd2..ff015cc5c084 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -86,6 +86,9 @@ package body Checks is -- the ability to emit constraint error warning for static expressions -- even when we are not generating code. + -- The above is modified in gnatprove mode to ensure that proper check + -- flags are always placed, even if expansion is off. + ------------------------------------- -- Suppression of Redundant Checks -- ------------------------------------- @@ -3540,17 +3543,16 @@ package body Checks is else Dref := Make_Selected_Component (Loc, - Prefix => + Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True), - Selector_Name => - Make_Identifier (Loc, Chars (Disc_Ent))); + Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); Set_Is_In_Discriminant_Check (Dref); end if; Evolve_Or_Else (Cond, Make_Op_Ne (Loc, - Left_Opnd => Dref, + Left_Opnd => Dref, Right_Opnd => Dval)); Next_Elmt (Disc); @@ -3584,10 +3586,9 @@ package body Checks is function Left_Expression (Op : Node_Id) return Node_Id is LE : Node_Id := Left_Opnd (Op); begin - while Nkind_In (LE, - N_Qualified_Expression, - N_Type_Conversion, - N_Expression_With_Actions) + while Nkind_In (LE, N_Qualified_Expression, + N_Type_Conversion, + N_Expression_With_Actions) loop LE := Expression (LE); end loop; @@ -3650,7 +3651,7 @@ package body Checks is exit when (N = Right_Opnd (P) or else (Is_List_Member (N) - and then List_Containing (N) = Actions (P))) + and then List_Containing (N) = Actions (P))) and then Nkind (Left_Expression (P)) = N_Op_Ne; end if; @@ -3669,9 +3670,7 @@ package body Checks is -- Left operand of test must match original variable - if Nkind (L) not in N_Has_Entity - or else Entity (L) /= Entity (Nod) - then + if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then return True; end if; @@ -3961,6 +3960,7 @@ package body Checks is else Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); + if Debug_Flag_CC then w ("Conditional_Statements_End: Num_Saved_Checks = ", Num_Saved_Checks); @@ -4287,7 +4287,6 @@ package body Checks is then Lor := Lo_Left / Lo_Right; Hir := Hi_Left / Lo_Right; - else OK1 := False; end if; @@ -4782,8 +4781,8 @@ package body Checks is end if; -- If we get an exception, then something went wrong, probably because of - -- an error in the structure of the tree due to an incorrect program. Or it - -- may be a bug in the optimization circuit. In either case the safest + -- an error in the structure of the tree due to an incorrect program. Or + -- it may be a bug in the optimization circuit. In either case the safest -- thing is simply to set the check flag unconditionally. exception @@ -4832,9 +4831,7 @@ package body Checks is -- No check if range checks suppressed for type of node - if Present (Etype (N)) - and then Range_Checks_Suppressed (Etype (N)) - then + if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then return; -- No check if node is an entity name, and range checks are suppressed @@ -4842,7 +4839,7 @@ package body Checks is elsif Is_Entity_Name (N) and then (Range_Checks_Suppressed (Entity (N)) - or else Range_Checks_Suppressed (Etype (Entity (N)))) + or else Range_Checks_Suppressed (Etype (Entity (N)))) then return; @@ -5180,9 +5177,8 @@ package body Checks is -- formal is not OUT). This test also filters out the -- generic case. - if Is_Non_Empty_List (L) - and then Is_Subprogram (E) - then + if Is_Non_Empty_List (L) and then Is_Subprogram (E) then + -- This is the loop through parameters, looking for an -- OUT parameter for which we are the argument. @@ -5294,26 +5290,18 @@ package body Checks is -- Integer and character literals always have valid values, where -- appropriate these will be range checked in any case. - elsif Nkind (Expr) = N_Integer_Literal - or else - Nkind (Expr) = N_Character_Literal - then + elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then return True; -- Real literals are assumed to be valid in VM targets - elsif VM_Target /= No_VM - and then Nkind (Expr) = N_Real_Literal - then + elsif VM_Target /= No_VM and then Nkind (Expr) = N_Real_Literal then return True; -- If we have a type conversion or a qualification of a known valid -- value, then the result will always be valid. - elsif Nkind (Expr) = N_Type_Conversion - or else - Nkind (Expr) = N_Qualified_Expression - then + elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then return Expr_Known_Valid (Expression (Expr)); -- The result of any operator is always considered valid, since we @@ -5324,10 +5312,9 @@ package body Checks is elsif Nkind (Expr) in N_Op then if Is_Floating_Point_Type (Typ) and then Validity_Check_Floating_Point - and then - (Nkind (Parent (Expr)) = N_Assignment_Statement - or else Nkind (Parent (Expr)) = N_Function_Call - or else Nkind (Parent (Expr)) = N_Parameter_Association) + and then (Nkind_In (Parent (Expr), N_Assignment_Statement, + N_Function_Call, + N_Parameter_Association)) then return False; else @@ -5468,7 +5455,6 @@ package body Checks is for J in reverse 1 .. Num_Saved_Checks loop declare SC : Saved_Check renames Saved_Checks (J); - begin if SC.Killed = False and then SC.Entity = Ent @@ -5532,10 +5518,10 @@ package body Checks is -- Force evaluation of the prefix, so that it does not get evaluated -- twice (once for the check, once for the actual reference). Such a - -- double evaluation is always a potential source of inefficiency, - -- and is functionally incorrect in the volatile case, or when the - -- prefix may have side-effects. An entity or a component of an - -- entity requires no evaluation. + -- double evaluation is always a potential source of inefficiency, and + -- is functionally incorrect in the volatile case, or when the prefix + -- may have side-effects. A non-volatile entity or a component of a + -- non-volatile entity requires no evaluation. if Is_Entity_Name (Pref) then if Treat_As_Volatile (Entity (Pref)) then @@ -5543,7 +5529,7 @@ package body Checks is end if; elsif Treat_As_Volatile (Etype (Pref)) then - Force_Evaluation (Pref, Name_Req => True); + Force_Evaluation (Pref, Name_Req => True); elsif Nkind (Pref) = N_Selected_Component and then Is_Entity_Name (Prefix (Pref)) @@ -5629,7 +5615,7 @@ package body Checks is Make_Raise_Constraint_Error (Loc, Condition => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Discr_Fct, Loc), + Name => New_Occurrence_Of (Discr_Fct, Loc), Parameter_Associations => Args), Reason => CE_Discriminant_Check_Failed)); end Generate_Discriminant_Check; @@ -5680,8 +5666,7 @@ package body Checks is -- for array object or type. if not Is_Array_Type (Etype (A)) - or else (Present (A_Ent) - and then Index_Checks_Suppressed (A_Ent)) + or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent)) or else Index_Checks_Suppressed (Etype (A)) then return; @@ -6088,7 +6073,7 @@ package body Checks is else pragma Assert (not Is_Unsigned_Type (Source_Base_Type) - and then Is_Unsigned_Type (Target_Base_Type)); + and then Is_Unsigned_Type (Target_Base_Type)); -- If the source is signed and the target is unsigned, then we -- know that the target is not shorter than the source (otherwise @@ -6141,7 +6126,7 @@ package body Checks is Right_Opnd => New_Occurrence_Of (Target_Type, Loc))), - Reason => Reason)), + Reason => Reason)), Suppress => All_Checks); -- Set the Etype explicitly, because Insert_Actions may have @@ -6205,7 +6190,6 @@ package body Checks is while Present (Sc) loop if Sc = Standard_Standard then return Bound; - elsif Ekind (Sc) = E_Protected_Type then exit; end if; @@ -6236,8 +6220,8 @@ package body Checks is Warn_Node : Node_Id := Empty) return Check_Result is begin - return Selected_Range_Checks - (Ck_Node, Target_Typ, Source_Typ, Warn_Node); + return + Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node); end Get_Range_Checks; ------------------ @@ -6256,6 +6240,7 @@ package body Checks is if Nkind (Ck_Node) = N_Allocator then return Cond; + else return Make_And_Then (Loc, @@ -6475,7 +6460,7 @@ package body Checks is if Is_Entity_Name (Exp) and then Nkind (Parent (Entity (Exp))) = - N_Object_Renaming_Declaration + N_Object_Renaming_Declaration then declare Old_Exp : constant Node_Id := Name (Parent (Entity (Exp))); @@ -6602,9 +6587,9 @@ package body Checks is return False; end if; - -- If we are in a case expression, and not part of the - -- expression, then we return False, since a particular - -- dependent expression may not always be elaborated + -- If within a case expression, and not part of the expression, + -- then return False, since a particular dependent expression + -- may not always be elaborated if Nkind (P) = N_Case_Expression and then N /= Expression (P) @@ -6612,9 +6597,8 @@ package body Checks is return False; end if; - -- While traversing the parent chain, we find that N - -- belongs to a statement, thus it may never appear in - -- a declarative region. + -- While traversing the parent chain, if node N belongs to a + -- statement, then it may never appear in a declarative region. if Nkind (P) in N_Statement_Other_Than_Procedure_Call or else Nkind (P) = N_Procedure_Call_Statement @@ -6696,9 +6680,11 @@ package body Checks is if Known_Null (N) then - -- Avoid generating warning message inside init procs + -- Avoid generating warning message inside init procs. In SPARK mode + -- we can go ahead and call Apply_Compile_Time_Constraint_Error + -- since it will be truned into an error in any case. - if not Inside_Init_Proc then + if not Inside_Init_Proc or else SPARK_Mode = On then Apply_Compile_Time_Constraint_Error (N, "null value not allowed here??", CE_Access_Check_Failed); else @@ -7163,7 +7149,7 @@ package body Checks is end if; -- If we don't have a binary operator, all we have to do is to set - -- the Hi/Lo range, so we are done + -- the Hi/Lo range, so we are done. return; @@ -7329,7 +7315,7 @@ package body Checks is -- If we have an arithmetic operator we make recursive calls on the -- operands to get the ranges (and to properly process the subtree - -- that lies below us!) + -- that lies below us). Minimize_Eliminate_Overflows (Right_Opnd (N), Rlo, Rhi, Top_Level => False); @@ -8134,7 +8120,8 @@ package body Checks is begin if Present (N) then - -- For now, ignore attempt to place more than 2 checks ??? + -- For now, ignore attempt to place more than two checks ??? + -- This is really worrisome, are we really discarding checks ??? if Num_Checks = 2 then return; @@ -9003,7 +8990,6 @@ package body Checks is then HB := T_HB; Known_HB := True; - else Known_HB := False; end if; @@ -9158,9 +9144,7 @@ package body Checks is -- and replace the literal with a raise constraint error -- expression. As usual, skip this for access types - elsif Compile_Time_Known_Value (Ck_Node) - and then not Do_Access - then + elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then declare LB : constant Node_Id := Type_Low_Bound (T_Typ); UB : constant Node_Id := Type_High_Bound (T_Typ); @@ -9442,9 +9426,9 @@ package body Checks is and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Tag_Check); + else + return Scope_Suppress.Suppress (Tag_Check); end if; - - return Scope_Suppress.Suppress (Tag_Check); end Tag_Checks_Suppressed; -------------------------- diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 601030c36714..19264cb9ec48 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -1378,12 +1378,6 @@ package body Exp_Pakd is -- contains the value. Otherwise Rhs_Val_Known is set False, and -- the Rhs_Val is undefined. - Require_Byte_Swapping : Boolean := False; - -- True if byte swapping required, for the Reverse_Storage_Order case - -- when the packed array is a free-standing object. (If it is part - -- of a composite type, and therefore potentially not aligned on a byte - -- boundary, the swapping is done by the back-end). - function Get_Shift return Node_Id; -- Function used to get the value of Shift, making sure that it -- gets duplicated if the function is called more than once. @@ -1562,25 +1556,8 @@ package body Exp_Pakd is -- array type on Obj to get lost. So we save the type of Obj, and -- make sure it is reset properly. - declare - T : constant Entity_Id := Etype (Obj); - begin - New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True); - New_Rhs := Duplicate_Subexpr_No_Checks (Obj); - Set_Etype (Obj, T); - Set_Etype (New_Lhs, T); - Set_Etype (New_Rhs, T); - - if Reverse_Storage_Order (Base_Type (Atyp)) - and then Esize (T) > 8 - and then not In_Reverse_Storage_Order_Object (Obj) - then - Require_Byte_Swapping := True; - New_Rhs := Byte_Swap (New_Rhs, - Left_Justify => Bytes_Big_Endian, - Right_Justify => not Bytes_Big_Endian); - end if; - end; + New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True); + New_Rhs := Duplicate_Subexpr_No_Checks (Obj); -- First we deal with the "and" @@ -1703,13 +1680,6 @@ package body Exp_Pakd is Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs))); end if; - -- If New_Rhs has been byte swapped, need to convert Or_Rhs - -- to the return type of the byte swapping function now. - - if Require_Byte_Swapping then - Or_Rhs := Unchecked_Convert_To (Etype (New_Rhs), Or_Rhs); - end if; - New_Rhs := Make_Op_Or (Loc, Left_Opnd => New_Rhs, @@ -1717,15 +1687,6 @@ package body Exp_Pakd is end; end if; - if Require_Byte_Swapping then - Set_Etype (New_Rhs, Etype (Obj)); - New_Rhs := - Unchecked_Convert_To (Etype (Obj), - Byte_Swap (New_Rhs, - Left_Justify => not Bytes_Big_Endian, - Right_Justify => Bytes_Big_Endian)); - end if; - -- Now do the rewrite Rewrite (N, @@ -2043,11 +2004,6 @@ package body Exp_Pakd is Lit : Node_Id; Arg : Node_Id; - Byte_Swapped : Boolean; - -- Set true if bytes were swapped for the purpose of extracting the - -- element, in which case we must swap back if the component type is - -- a composite type with reverse scalar storage order. - begin -- If the node is an actual in a call, the prefix has not been fully -- expanded, to account for the additional expansion for in-out actuals @@ -2106,23 +2062,6 @@ package body Exp_Pakd is Lit := Make_Integer_Literal (Loc, Cmask); Set_Print_In_Hex (Lit); - -- Byte swapping required for the Reverse_Storage_Order case, but - -- only for a free-standing object (see note on Require_Byte_Swapping - -- in Expand_Bit_Packed_Element_Set). - - if Reverse_Storage_Order (Atyp) - and then Esize (Atyp) > 8 - and then not In_Reverse_Storage_Order_Object (Obj) - then - Obj := Byte_Swap (Obj, - Left_Justify => Bytes_Big_Endian, - Right_Justify => not Bytes_Big_Endian); - Byte_Swapped := True; - - else - Byte_Swapped := False; - end if; - -- We generate a shift right to position the field, followed by a -- masking operation to extract the bit field, and we finally do an -- unchecked conversion to convert the result to the required target. @@ -2137,12 +2076,16 @@ package body Exp_Pakd is Make_Op_And (Loc, Left_Opnd => Make_Shift_Right (Obj, Shift), Right_Opnd => Lit); - - -- Swap back if necessary - Set_Etype (Arg, Ctyp); - if Byte_Swapped + -- Component extraction is performed on a native endianness scalar + -- value: if Atyp has reverse storage order, then it has been byte + -- swapped, and if the component being extracted is itself of a + -- composite type with reverse storage order, then we need to swap + -- it back to its expected endianness after extraction. + + if Reverse_Storage_Order (Atyp) + and then Esize (Atyp) > 8 and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp)) and then Reverse_Storage_Order (Ctyp) then diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 6c283e4fdbf1..6885625c67a1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1083,6 +1083,10 @@ package body Freeze is -- Set True for the record case, when Comp starts on a byte boundary -- (in which case it is allowed to have different storage order). + Comp_SSO_Differs : Boolean; + -- Set True when the component is a nested composite, and it does not + -- have the same scalar storage order as Encl_Type. + Component_Aliased : Boolean; begin @@ -1136,28 +1140,42 @@ package body Freeze is -- attribute on Comp_Type if composite. elsif Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then + Comp_SSO_Differs := + Reverse_Storage_Order (Encl_Type) + /= + Reverse_Storage_Order (Comp_Type); + if Present (Comp) and then Chars (Comp) = Name_uParent then - if Reverse_Storage_Order (Encl_Type) - /= - Reverse_Storage_Order (Comp_Type) - then + if Comp_SSO_Differs then Error_Msg_N ("record extension must have same scalar storage order as " & "parent", Err_Node); end if; - elsif No (ADC) then + elsif No (Comp_ADC) then Error_Msg_N ("nested composite must have explicit scalar " & "storage order", Err_Node); - elsif (Reverse_Storage_Order (Encl_Type) - /= - Reverse_Storage_Order (Comp_Type)) - and then not Comp_Byte_Aligned - then - Error_Msg_N - ("type of non-byte-aligned component must have same scalar " - & "storage order as enclosing composite", Err_Node); + elsif Comp_SSO_Differs then + + -- Component SSO differs from enclosing composite: + + -- Reject if component is a packed array, as it may be represented + -- as a scalar internally. + + if Is_Packed (Comp_Type) then + Error_Msg_N + ("type of packed component must have same scalar " + & "storage order as enclosing composite", Err_Node); + + -- Reject if not byte aligned + + elsif not Comp_Byte_Aligned then + Error_Msg_N + ("type of non-byte-aligned component must have same scalar " + & "storage order as enclosing composite", Err_Node); + + end if; end if; -- Enclosing type has explicit SSO, non-composite component must not diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9e808b54a600..7751971e0dce 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -562,8 +562,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ s-vxwext.adb Prefix_Type, Rep => False); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ba76ca680a20..a093a395ddb6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -122,7 +122,7 @@ package Sem_Util is -- is present, this is used instead. Warn is normally False. If it is -- True then the message is treated as a warning even though it does -- not end with a ? (this is used when the caller wants to parameterize - -- whether an error or warning is given. + -- whether an error or warning is given). function Async_Readers_Enabled (Id : Entity_Id) return Boolean; -- Given the entity of an abstract state or a variable, determine whether