diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 42 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_pakd.adb | 69 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 117 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/layout.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 4 |
12 files changed, 202 insertions, 114 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dd5f7e1..c74abd0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2014-05-21 Robert Dewar <dewar@adacore.com> + + * gnatcmd.adb: Minor error msg changes (no upper case letter + at start). + * sem_ch12.adb, sem_ch5.adb, sem_res.adb, sem_util.adb: Minor + reformatting. + +2014-05-21 Robert Dewar <dewar@adacore.com> + + * debug.adb: Debug flag -gnatd.G inhibits static elab tracing + via generic formals. + * sem_elab.adb (Is_Call_Of_Generic_Formal): Return False if + -gnatd.G is set. + +2014-05-21 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb (Revert_Storage_Order): Renamed from Byte_Swap to + more accurately describe that this subprogram needs to come into + play also in cases where no byte swapping is involved, because + it also takes care of some required shifts (left-justification + of values). + +2014-05-21 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Indicate whether + a Scalar_Storage_Order attribute definition is present for the + component's type. + (Freeze_Record_Type): Suppress junk warnings + about purportedly junk Bit_Order / Scalar_Storage_Order attribute + definitions. + +2014-05-21 Robert Dewar <dewar@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Put back call + to Kill_Elaboration_Checks. + +2014-05-21 Gary Dismukes <dismukes@adacore.com> + + * layout.adb (Assoc_Add): Suppress the optimization of the (E + - C1) + C2 case, when the expression type is unsigned and C1 < + C2, to avoid creating a negative literal when folding. + 2014-05-21 Hristian Kirtchev <kirtchev@adacore.com> * freeze.adb (Freeze_Record_Type): Update the use of diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d5fae27..8399a2c 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -124,7 +124,7 @@ package body Debug is -- d.D -- d.E Turn selected errors into warnings -- d.F Debug mode for GNATprove - -- d.G + -- d.G Ignore calls through generic formal parameters for elaboration -- d.H -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Disable parallel SCIL generation mode @@ -623,6 +623,11 @@ package body Debug is -- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in -- the special mode used by GNATprove. + -- d.G Previously the compiler ignored calls via generic formal parameters + -- when doing the analysis for the static elaboration model. This is + -- now fixed, but we provide this debug flag to revert to the previous + -- situation of ignoring such calls to aid in transition. + -- d.I Do not ignore enum representation clauses in CodePeer mode. -- The default of ignoring representation clauses for enumeration -- types in CodePeer is good for the majority of Ada code, but in some diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index fcaba80..9569979 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -543,25 +543,19 @@ package body Exp_Pakd is -- array type on the fly). Such actions are inserted into the tree -- directly using Insert_Action. - function Byte_Swap - (N : Node_Id; - Left_Justify : Boolean := False; - Right_Justify : Boolean := False) return Node_Id; - -- Wrap N in a call to a byte swapping function, with appropriate type - -- conversions. If Left_Justify is set True, the value is left justified - -- before swapping. If Right_Justify is set True, the value is right - -- justified after swapping. The Etype of the returned node is an - -- integer type of an appropriate power-of-2 size. - - --------------- - -- Byte_Swap -- - --------------- - - function Byte_Swap - (N : Node_Id; - Left_Justify : Boolean := False; - Right_Justify : Boolean := False) return Node_Id - is + function Revert_Storage_Order (N : Node_Id) return Node_Id; + -- Perform appropriate justification and byte ordering adjustments for N, + -- an element of a packed array type, when both the component type and + -- the enclosing packed array type have reverse scalar storage order. + -- On little-endian targets, the value is left justified before byte + -- swapping. The Etype of the returned expression is an integer type of + -- an appropriate power-of-2 size. + + -------------------------- + -- Revert_Storage_Order -- + -------------------------- + + function Revert_Storage_Order (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); T : constant Entity_Id := Etype (N); T_Size : constant Uint := RM_Size (T); @@ -571,16 +565,21 @@ package body Exp_Pakd is Swap_T : Entity_Id; -- Swapping function - Arg : Node_Id; - Swapped : Node_Id; - Shift : Uint; + Arg : Node_Id; + Adjusted : Node_Id; + Shift : Uint; begin if T_Size <= 8 then + + -- Array component size is less than a byte: no swapping needed + Swap_F := Empty; Swap_T := RTE (RE_Unsigned_8); else + -- Select byte swapping function depending on array component size + if T_Size <= 16 then Swap_RE := RE_Bswap_16; @@ -600,7 +599,7 @@ package body Exp_Pakd is Arg := RJ_Unchecked_Convert_To (Swap_T, N); - if Left_Justify and then Shift > Uint_0 then + if not Bytes_Big_Endian and then Shift > Uint_0 then Arg := Make_Op_Shift_Left (Loc, Left_Opnd => Arg, @@ -608,24 +607,17 @@ package body Exp_Pakd is end if; if Present (Swap_F) then - Swapped := + Adjusted := Make_Function_Call (Loc, Name => New_Occurrence_Of (Swap_F, Loc), Parameter_Associations => New_List (Arg)); else - Swapped := Arg; - end if; - - if Right_Justify and then Shift > Uint_0 then - Swapped := - Make_Op_Shift_Right (Loc, - Left_Opnd => Swapped, - Right_Opnd => Make_Integer_Literal (Loc, Shift)); + Adjusted := Arg; end if; - Set_Etype (Swapped, Swap_T); - return Swapped; - end Byte_Swap; + Set_Etype (Adjusted, Swap_T); + return Adjusted; + end Revert_Storage_Order; ------------------------------ -- Compute_Linear_Subscript -- @@ -2095,15 +2087,10 @@ package body Exp_Pakd is -- 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 - Arg := - Byte_Swap - (Arg, - Left_Justify => not Bytes_Big_Endian, - Right_Justify => False); + Arg := Revert_Storage_Order (Arg); end if; -- We needed to analyze this before we do the unchecked convert diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e48cb9f..e091cea 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -90,16 +90,19 @@ package body Freeze is -- performed only after the object has been frozen. procedure Check_Component_Storage_Order - (Encl_Type : Entity_Id; - Comp : Entity_Id; - ADC : Node_Id); + (Encl_Type : Entity_Id; + Comp : Entity_Id; + ADC : Node_Id; + Comp_ADC_Present : out Boolean); -- For an Encl_Type that has a Scalar_Storage_Order attribute definition -- clause, verify that the component type has an explicit and compatible -- attribute/aspect. For arrays, Comp is Empty; for records, it is the -- entity of the component under consideration. For an Encl_Type that -- does not have a Scalar_Storage_Order attribute definition clause, -- verify that the component also does not have such a clause. - -- ADC is the attribute definition clause if present (or Empty). + -- ADC is the attribute definition clause if present (or Empty). On return, + -- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order + -- attribute definition clause. procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased @@ -1070,9 +1073,10 @@ package body Freeze is ----------------------------------- procedure Check_Component_Storage_Order - (Encl_Type : Entity_Id; - Comp : Entity_Id; - ADC : Node_Id) + (Encl_Type : Entity_Id; + Comp : Entity_Id; + ADC : Node_Id; + Comp_ADC_Present : out Boolean) is Comp_Type : Entity_Id; Comp_ADC : Node_Id; @@ -1124,12 +1128,13 @@ package body Freeze is Comp_ADC := Get_Attribute_Definition_Clause (First_Subtype (Comp_Type), Attribute_Scalar_Storage_Order); + Comp_ADC_Present := Present (Comp_ADC); -- Case of enclosing type not having explicit SSO: component cannot -- have it either. if No (ADC) then - if Present (Comp_ADC) then + if Comp_ADC_Present then Error_Msg_N ("composite type must have explicit scalar storage order", Err_Node); @@ -2350,14 +2355,19 @@ package body Freeze is -- Check for scalar storage order - Check_Component_Storage_Order - (Encl_Type => Arr, - Comp => Empty, - ADC => Get_Attribute_Definition_Clause - (First_Subtype (Arr), - Attribute_Scalar_Storage_Order)); + declare + Dummy : Boolean; + begin + Check_Component_Storage_Order + (Encl_Type => Arr, + Comp => Empty, + ADC => Get_Attribute_Definition_Clause + (First_Subtype (Arr), + Attribute_Scalar_Storage_Order), + Comp_ADC_Present => Dummy); + end; - -- Processing that is done only for subtypes + -- Processing that is done only for subtypes else -- Acquire alignment from base type @@ -2549,8 +2559,8 @@ package body Freeze is procedure Freeze_Record_Type (Rec : Entity_Id) is Comp : Entity_Id; IR : Node_Id; - ADC : Node_Id; Prev : Entity_Id; + ADC : Node_Id; Junk : Boolean; pragma Warnings (Off, Junk); @@ -2560,6 +2570,9 @@ package body Freeze is -- stack. Needed for the analysis of delayed aspects specified to the -- components of Rec. + SSO_ADC : Node_Id; + -- Scalar_Storage_Order attribute definition clause for the record + Unplaced_Component : Boolean := False; -- Set True if we find at least one component with no component -- clause (used to warn about useless Pack pragmas). @@ -2574,6 +2587,10 @@ package body Freeze is -- is used to prevent Implicit_Packing of the record, since packing -- cannot modify the size of alignment of an aliased component. + SSO_ADC_Component : Boolean := False; + -- Set True if we find at least one component whose type has a + -- Scalar_Storage_Order attribute definition clause. + All_Scalar_Components : Boolean := True; -- Set False if we encounter a component of a non-scalar type @@ -3014,56 +3031,80 @@ package body Freeze is Next_Entity (Comp); end loop; - ADC := Get_Attribute_Definition_Clause - (Rec, Attribute_Scalar_Storage_Order); + SSO_ADC := Get_Attribute_Definition_Clause + (Rec, Attribute_Scalar_Storage_Order); + + -- Check consistent attribute setting on component types + + declare + Comp_ADC_Present : Boolean; + begin + Comp := First_Component (Rec); + while Present (Comp) loop + Check_Component_Storage_Order + (Encl_Type => Rec, + Comp => Comp, + ADC => SSO_ADC, + Comp_ADC_Present => Comp_ADC_Present); + SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present; + Next_Component (Comp); + end loop; + end; - if Present (ADC) then + if Present (SSO_ADC) then -- Check compatibility of Scalar_Storage_Order with Bit_Order, if -- the former is specified. if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then - -- Note: report error on Rec, not on ADC, as ADC may apply to - -- an ancestor type. + -- Note: report error on Rec, not on SSO_ADC, as ADC may apply + -- to some ancestor type. - Error_Msg_Sloc := Sloc (ADC); + Error_Msg_Sloc := Sloc (SSO_ADC); Error_Msg_N ("scalar storage order for& specified# inconsistent with " & "bit order", Rec); end if; - -- Warn if there is a Scalar_Storage_Order but no component clause - -- (or pragma Pack). + -- Warn if there is an Scalar_Storage_Order attribute definition + -- clause but no component clause, no component that itself has + -- such an attribute definition, and no pragma Pack. - if not (Placed_Component or else Is_Packed (Rec)) then + if not (Placed_Component + or else + SSO_ADC_Component + or else + Is_Packed (Rec)) + then Error_Msg_N ("??scalar storage order specified but no component clause", - ADC); + SSO_ADC); end if; end if; - -- Check consistent attribute setting on component types - - Comp := First_Component (Rec); - while Present (Comp) loop - Check_Component_Storage_Order - (Encl_Type => Rec, Comp => Comp, ADC => ADC); - Next_Component (Comp); - end loop; - - -- Deal with Bit_Order aspect specifying a non-default bit order + -- Deal with Bit_Order aspect ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); if Present (ADC) and then Base_Type (Rec) = Rec then - if not (Placed_Component or else Is_Packed (Rec)) then + if not (Placed_Component + or else + Present (SSO_ADC) + or else + Is_Packed (Rec)) + then + -- Warn if clause has no effect when no component clause is + -- present, but suppress warning if the Bit_Order is required + -- due to the presence of a Scalar_Storage_Order attribute. + Error_Msg_N ("??bit order specification has no effect", ADC); Error_Msg_N ("\??since no component clauses were specified", ADC); - -- Here is where we do the processing for reversed bit order + -- Here is where we do the processing to adjust component clauses + -- for reversed bit order. elsif Reverse_Bit_Order (Rec) and then not Reverse_Storage_Order (Rec) diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index b2a865c..50bc3ad 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1527,7 +1527,7 @@ begin if Command_List (The_Command).VMS_Only then Non_VMS_Usage; Fail - ("Command """ + ("command """ & Command_List (The_Command).Cname.all & """ can only be used on VMS"); end if; @@ -1542,13 +1542,13 @@ begin begin Alternate := Alternate_Command'Value - (Argument (Command_Arg)); + (Argument (Command_Arg)); The_Command := Corresponding_To (Alternate); exception when Constraint_Error => Non_VMS_Usage; - Fail ("Unknown command: " & Argument (Command_Arg)); + Fail ("unknown command: " & Argument (Command_Arg)); end; end; @@ -1578,12 +1578,9 @@ begin exception when others => - Put - (Standard_Error, "Cannot open argument file """); - Put - (Standard_Error, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); - + Put (Standard_Error, "Cannot open argument file """); + Put (Standard_Error, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); Put_Line (Standard_Error, """"); raise Error_Exit; end; @@ -1816,7 +1813,7 @@ begin end case; else Fail ("invalid verbosity level: " - & Argv (Argv'First + 3 .. Argv'Last)); + & Argv (Argv'First + 3 .. Argv'Last)); end if; Remove_Switch (Arg_Num); @@ -2104,13 +2101,13 @@ begin end if; end; - if The_Command = Bind - or else The_Command = Link - or else The_Command = Elim + if The_Command = Bind or else + The_Command = Link or else + The_Command = Elim then if Project.Object_Directory.Name = No_Path then - Fail ("project " & Get_Name_String (Project.Display_Name) & - " has no object directory"); + Fail ("project " & Get_Name_String (Project.Display_Name) + & " has no object directory"); end if; Change_Dir (Get_Name_String (Project.Object_Directory.Name)); diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 829d75c..fe8ea04 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -353,7 +353,7 @@ package body Layout is elsif Nkind (L) = N_Op_Subtract then - -- (C1 - E) + C2 = (C1 + C2) + E + -- (C1 - E) + C2 = (C1 + C2) - E if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then Rewrite_Integer @@ -363,7 +363,14 @@ package body Layout is -- (E - C1) + C2 = E - (C1 - C2) - elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then + -- If the type is unsigned, then only do the optimization if + -- C1 >= C2, to avoid creating a negative literal that can't be + -- used with the unsigned type. + + elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) + and then (not Is_Unsigned_Type (Etype (Sinfo.Right_Opnd (L))) + or else Expr_Value (Sinfo.Right_Opnd (L)) >= R) + then Rewrite_Integer (Sinfo.Right_Opnd (L), Expr_Value (Sinfo.Right_Opnd (L)) - R); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5494ab5..2d74876 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10070,7 +10070,6 @@ package body Sem_Ch12 is Set_Corresponding_Spec (Act_Body, Act_Decl_Id); Check_Generic_Actuals (Act_Decl_Id, False); - Check_Initialized_Types; -- Install primitives hidden at the point of the instantiation but diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 60080ed..db7e985 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1875,7 +1875,6 @@ package body Sem_Ch5 is if No (Elt) then Error_Msg_N ("missing Element primitive for iteration", N); - else Set_Etype (Def_Id, Etype (Elt)); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 4c5147c..43cd4fd 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2505,26 +2505,25 @@ package body Sem_Ch8 is end if; end if; - -- At this point, we used to have the following, but we removed it - -- because it was certainly wrong for generic formal parameters in - -- at least some cases, causing elaboration checks to be skipped. - -- Possibly it is helpful in some other cases, but it caused no - -- regressions to remove it completely. - -- There is no need for elaboration checks on the new entity, which may -- be called before the next freezing point where the body will appear. -- Elaboration checks refer to the real entity, not the one created by -- the renaming declaration. - -- Set_Kill_Elaboration_Checks (New_S, True); + Set_Kill_Elaboration_Checks (New_S, True); + + -- If we had a previous error, indicate a completely is present to stop + -- junk cascaded messages, but don't take any further action. if Etype (Nam) = Any_Type then Set_Has_Completion (New_S); return; + -- Case where name has the form of a selected component + elsif Nkind (Nam) = N_Selected_Component then - -- A prefix of the form A.B can designate an entry of task A, a + -- A name which has the form A.B can designate an entry of task A, a -- protected operation of protected object A, or finally a primitive -- operation of object A. In the later case, A is an object of some -- tagged type, or an access type that denotes one such. To further @@ -2573,6 +2572,8 @@ package body Sem_Ch8 is end if; end; + -- Case where name is an explicit dereference X.all + elsif Nkind (Nam) = N_Explicit_Dereference then -- Renamed entity is designated by access_to_subprogram expression. @@ -2581,14 +2582,21 @@ package body Sem_Ch8 is Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec)); return; + -- Indexed component + elsif Nkind (Nam) = N_Indexed_Component then Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec)); return; + -- Character literal + elsif Nkind (Nam) = N_Character_Literal then Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); return; + -- Only remaining case is where we have a non-entity name, or a + -- renaming of some other non-overloadable entity. + elsif not Is_Entity_Name (Nam) or else not Is_Overloadable (Entity (Nam)) then diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 02762ff..7f494d8 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -552,6 +552,10 @@ package body Sem_Elab is begin return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + -- Always return False if debug flag -gnatd.G is set + + and then not Debug_Flag_Dot_GG + -- For now, we detect this by looking for the strange identifier -- node, whose Chars reflect the name of the generic formal, but -- the Chars of the Entity references the generic actual. @@ -564,10 +568,12 @@ package body Sem_Elab is begin -- If the call is known to be within a local Suppress Elaboration - -- pragma, nothing to check. This can happen in task bodies. + -- pragma, nothing to check. This can happen in task bodies. But + -- we ignore this for a call to a generic formal. if Nkind (N) in N_Subprogram_Call and then No_Elaboration_Check (N) + and then not Is_Call_Of_Generic_Formal then return; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2273fe8..c1f9f8c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6583,8 +6583,7 @@ package body Sem_Res is and then Is_SPARK_Volatile (E) and then Comes_From_Source (E) and then - (Async_Writers_Enabled (E) - or else Effective_Reads_Enabled (E)) + (Async_Writers_Enabled (E) or else Effective_Reads_Enabled (E)) then -- The volatile object can appear on either side of an assignment diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 29de16b..84570fb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7500,9 +7500,7 @@ package body Sem_Util is elsif Property = Name_Effective_Writes and then - (Present (EW) - or else - (No (AR) and then No (AW) and then No (ER))) + (Present (EW) or else (No (AR) and then No (AW) and then No (ER))) then return True; |