From: Arnaud Charlet Date: Thu, 23 Oct 2014 10:45:48 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ad075b500fc6da9afd6a5bfc710a715b33b01e22;p=gcc.git [multiple changes] 2014-10-23 Ed Schonberg * sem_eval.adb (Check_Non_Static_Context): Do not set Is_Machine_Number on a literal of a fixed-point type. 2014-10-23 Robert Dewar * mlib-prj.adb, sem_ch4.adb, exp_ch3.adb: Minor reformatting. 2014-10-23 Pierre-Marie Derodat * exp_dbug.ads: Update ___XA parallel type specification. 2014-10-23 Hristian Kirtchev * sem_ch3.adb (Copy_Array_Subtype_Attributes): Inherit the rep chain of the source type. * sem_ch13.adb (Analyze_Aspect_Specifications): Minor reformatting of an error message. * sem_util.adb (Inherit_Rep_Item_Chain): Do not inherit a rep chain that has been inherited already. From-SVN: r216588 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 353d0a5f1be..7c3f5bb7c7d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2014-10-23 Ed Schonberg + + * sem_eval.adb (Check_Non_Static_Context): Do not set + Is_Machine_Number on a literal of a fixed-point type. + +2014-10-23 Robert Dewar + + * mlib-prj.adb, sem_ch4.adb, exp_ch3.adb: Minor reformatting. + +2014-10-23 Pierre-Marie Derodat + + * exp_dbug.ads: Update ___XA parallel type specification. + +2014-10-23 Hristian Kirtchev + + * sem_ch3.adb (Copy_Array_Subtype_Attributes): Inherit the rep + chain of the source type. + * sem_ch13.adb (Analyze_Aspect_Specifications): Minor + reformatting of an error message. + * sem_util.adb (Inherit_Rep_Item_Chain): Do not inherit a rep + chain that has been inherited already. + 2014-10-23 Ed Schonberg * sem_ch6.adb (Analyze_Expression_Function): Simplify analysis diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1480c0fa525..2de1887af75 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5366,9 +5366,9 @@ package body Exp_Ch3 is and then Static_Dispatch_Tables and then Is_Library_Level_Entity (Def_Id) and then Is_Library_Level_Tagged_Type (Base_Typ) - and then (Ekind (Base_Typ) = E_Record_Type - or else Ekind (Base_Typ) = E_Protected_Type - or else Ekind (Base_Typ) = E_Task_Type) + and then Ekind_In (Base_Typ, E_Record_Type, + E_Protected_Type, + E_Task_Type) and then not Has_Dispatch_Table (Base_Typ) then declare diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index eefc9c9c637..727be929aae 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -854,9 +854,8 @@ package Exp_Dbug is -- names of these types). -- To conserve space, we do not produce this type unless one of the - -- index types is either an enumeration type, has a variable upper - -- bound, has a lower bound different from the constant 1, is a biased - -- type, or is wider than "sizetype". + -- index types is either an enumeration type, has a variable lower or + -- upper bound or is a biased type. -- Given the full encoding of these types (see above description for -- the encoding of discrete types), this means that all necessary diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 236a636a85e..ff84abace85 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -2395,7 +2395,7 @@ package body MLib.Prj is -- because they are also needed for non Stand-Alone shared -- libraries. - -- Also ignore the shared libraries which are : + -- Also ignore the shared libraries which are: -- -lgnat- (7 + version'length chars) -- -lgnarl- (8 + version'length chars) @@ -2403,13 +2403,15 @@ package body MLib.Prj is if Next_Line (1 .. Nlast) /= "-static" and then Next_Line (1 .. Nlast) /= "-shared" and then Next_Line (1 .. Nlast) /= "-lgnarl" and then - Next_Line (1 .. Nlast) /= "-lgnat" and then - Next_Line - (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= - Shared_Lib ("gnarl") and then - Next_Line - (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= - Shared_Lib ("gnat") + Next_Line (1 .. Nlast) /= "-lgnat" + and then + Next_Line + (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= + Shared_Lib ("gnarl") + and then + Next_Line + (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= + Shared_Lib ("gnat") then if Next_Line (1) /= '-' then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c1c9eecfff1..15e232be336 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2701,7 +2701,7 @@ package body Sem_Ch13 is when Aspect_Default_Value => if not Is_Scalar_Type (E) then Error_Msg_N - ("aspect Default_Value must apply to a scalar_Type", N); + ("aspect Default_Value must apply to a scalar type", N); end if; Aitem := Empty; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 27c228647d8..5993bdb634d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8697,61 +8697,9 @@ package body Sem_Ch3 is Set_Has_Predicates (Derived_Type); end if; - -- The derived type inherits the representation clauses of the parent. - -- However, for a private type that is completed by a derivation, there - -- may be operation attributes that have been specified already (stream - -- attributes and External_Tag) and those must be provided. Finally, if - -- the partial view is a private extension, the representation items of - -- the parent have been inherited already, and should not be chained - -- twice to the derived type. - - -- Historic note: The guard below used to check whether the parent type - -- is tagged. This is no longer needed because an untagged derived type - -- may carry rep items of its own as a result of certain SPARK pragmas. - -- With the old guard in place, the rep items of the derived type were - -- clobbered. - - if Present (First_Rep_Item (Derived_Type)) then - declare - Par_Item : constant Node_Id := First_Rep_Item (Parent_Type); - Inherited : Boolean := False; - Item : Node_Id; - Last_Item : Node_Id; - - begin - -- Inspect the rep item chain of the derived type and perform the - -- following two functions: - -- 1) Determine whether the derived type already inherited the - -- rep items of the parent type. - -- 2) Find the last rep item of the derived type - - Item := First_Rep_Item (Derived_Type); - Last_Item := Item; - while Present (Item) loop - if Item = Par_Item then - Inherited := True; - exit; - end if; - - Last_Item := Item; - Item := Next_Rep_Item (Item); - end loop; + -- The derived type inherits the representation clauses of the parent - -- Nothing to do if the derived type already inherited the rep - -- items from the parent type, otherwise append the parent rep - -- item chain to that of the derived type. - - if not Inherited then - Set_Next_Rep_Item (Last_Item, Par_Item); - end if; - end; - - -- Otherwise the derived type lacks rep items and directly inherits the - -- rep items of the parent type. - - else - Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); - end if; + Inherit_Rep_Item_Chain (Derived_Type, Parent_Type); -- Propagate the attributes related to pragma Default_Initial_Condition -- from the parent type to the private extension. A derived type always @@ -13396,17 +13344,17 @@ package body Sem_Ch3 is begin Set_Size_Info (T1, T2); - Set_First_Index (T1, First_Index (T2)); - Set_Is_Aliased (T1, Is_Aliased (T2)); - Set_Is_Volatile (T1, Is_Volatile (T2)); - Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); - Set_Is_Constrained (T1, Is_Constrained (T2)); - Set_Depends_On_Private (T1, Has_Private_Component (T2)); - Set_First_Rep_Item (T1, First_Rep_Item (T2)); - Set_Convention (T1, Convention (T2)); - Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); - Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); - Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); + Set_First_Index (T1, First_Index (T2)); + Set_Is_Aliased (T1, Is_Aliased (T2)); + Set_Is_Volatile (T1, Is_Volatile (T2)); + Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); + Set_Is_Constrained (T1, Is_Constrained (T2)); + Set_Depends_On_Private (T1, Has_Private_Component (T2)); + Inherit_Rep_Item_Chain (T1, T2); + Set_Convention (T1, Convention (T2)); + Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); + Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); + Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); end Copy_Array_Subtype_Attributes; ----------------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7914fe1e11b..3f9fc98e78f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7591,7 +7591,7 @@ package body Sem_Ch4 is or else not Is_Variable (Obj) then Error_Msg_NE - ("actual for& must be a variable", Obj, Control); + ("actual for & must be a variable", Obj, Control); end if; end if; @@ -7602,9 +7602,8 @@ package body Sem_Ch4 is if not Is_Aliased_View (Obj) then Error_Msg_NE - ("object in prefixed call to& must be aliased" - & " (RM-2005 4.3.1 (13))", - Prefix (First_Actual), Subprog); + ("object in prefixed call to & must be aliased " + & " (RM-2005 4.3.1 (13))", Prefix (First_Actual), Subprog); end if; Analyze (First_Actual); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 1922d5eca9c..77eb48c36c5 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -498,13 +498,15 @@ package body Sem_Eval is -- differences in rounding between static and non-static -- expressions. AI-100 specifies that the effect of such rounding -- is implementation dependent, and in GNAT we round to nearest - -- even to match the run-time behavior. + -- even to match the run-time behavior. Note that this applies + -- to floating point literals, not fixed points ones, even though + -- their compiler representation is also as a universal real. Set_Realval (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); + Set_Is_Machine_Number (N); end if; - Set_Is_Machine_Number (N); end if; -- Check for out of range universal integer. This is a non-static diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 09f80949c4c..1f1128c2437 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9296,25 +9296,34 @@ package body Sem_Util is procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is From_Item : constant Node_Id := First_Rep_Item (From_Typ); - Item : Node_Id; + Item : Node_Id := Empty; + Last_Item : Node_Id := Empty; begin - -- Reach the end of the destination type's chain (if any). The traversal - -- ensures that we do not go past the last item. + -- Reach the end of the destination type's chain (if any) and capture + -- the last item. Item := First_Rep_Item (Typ); - while Present (Item) and then Present (Next_Rep_Item (Item)) loop + while Present (Item) loop + + -- Do not inherit a chain that has been inherited already + + if Item = From_Item then + return; + end if; + + Last_Item := Item; Item := Next_Rep_Item (Item); end loop; -- When the destination type has a rep item chain, the chain of the -- source type is appended to it. - if Present (Item) then - Set_Next_Rep_Item (Item, From_Item); + if Present (Last_Item) then + Set_Next_Rep_Item (Last_Item, From_Item); -- Otherwise the destination type directly inherits the rep item chain - -- of the source type. + -- of the source type (if any). else Set_First_Rep_Item (Typ, From_Item);