diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d5473a1c4d8..5c3df6f8e46 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2014-11-20 Thomas Quinot + + * g-socket.adb (To_Host_Entry): Guard against case of a + non-AF_INET entry. + +2014-11-20 Vadim Godunko + + * a-strunb-shared.adb (To_Unbounded_String): Use shared empty + object to construct return value when source string is empty or + requested length is zero. + * a-stwiun-shared.adb (To_Unbounded_Wide_String): Likewise. + * a-stzunb-shared.adb (To_Unbounded_Wide_Wide_String): Likewise. + +2014-11-20 Yannick Moy + + * a-cfhase.adb, a-cfinve.adb, a-cforma.adb, a-cfhama.adb, a-cforse.adb, + a-cofove.adb: Skip CodePeer analysis on body of all formal containers. + +2014-11-20 Arnaud Charlet + + * adaint.c: Fix typo. + * exp_util.adb (Make_Subtype_From_Expr): Complete previous change, + generate constant values. + * sem_eval.adb (Decompose_Expr): Fix latent bug leading to a wrong + evaluation to '0' of some unknown values. + +2014-11-20 Robert Dewar + + * repinfo.adb (List_Record_Info): Do not list discriminant in + unchecked union. + * sem_ch13.adb (Has_Good_Profile): Minor reformatting + (Analyze_Stream_TSS_Definition): Minor reformatting + (Analyze_Record_Representation_Clause): Do not issue warning + for missing rep clause for discriminant in unchecked union. + 2014-11-20 Vadim Godunko * a-strunb-shared.adb, a-stwiun-shared.adb, a-stzunb-shared.adb diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 1504f605d71..11dbc6fe66d 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -38,6 +38,7 @@ with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Maps with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 3bbcd125776..8d73a2c385c 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -38,6 +38,7 @@ with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Sets with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cfinve.adb b/gcc/ada/a-cfinve.adb index e3f917aaa1e..6574fcb4364 100644 --- a/gcc/ada/a-cfinve.adb +++ b/gcc/ada/a-cfinve.adb @@ -29,6 +29,7 @@ package body Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); function H (New_Item : Element_Type) return Holder renames To_Holder; function E (Container : Holder) return Element_Type renames Get; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index cceef9e11d7..bd088bd46df 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -37,6 +37,7 @@ with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Maps with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); ----------------------------- -- Node Access Subprograms -- diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index b53d08c0edf..e1203215cc9 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -41,6 +41,7 @@ with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Sets with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); ------------------------------ -- Access to Fields of Node -- diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 8fc7ed148b6..d9eb35639d0 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -33,6 +33,7 @@ with System; use type System.Address; package body Ada.Containers.Formal_Vectors with SPARK_Mode => Off is + pragma Annotate (CodePeer, Skip_Analysis); Growth_Factor : constant := 2; -- When growing a container, multiply current capacity by this. Doubling diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index 9c9246600e7..5cbe3602a5b 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -1609,17 +1609,35 @@ package body Ada.Strings.Unbounded is ------------------------- function To_Unbounded_String (Source : String) return Unbounded_String is - DR : constant Shared_String_Access := Allocate (Source'Length); + DR : Shared_String_Access; + begin - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_String; function To_Unbounded_String (Length : Natural) return Unbounded_String is - DR : constant Shared_String_Access := Allocate (Length); + DR : Shared_String_Access; + begin - DR.Last := Length; + if Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_String; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb index 284ffd3cf9e..34811b7b90b 100644 --- a/gcc/ada/a-stwiun-shared.adb +++ b/gcc/ada/a-stwiun-shared.adb @@ -1624,19 +1624,37 @@ package body Ada.Strings.Wide_Unbounded is function To_Unbounded_Wide_String (Source : Wide_String) return Unbounded_Wide_String is - DR : constant Shared_Wide_String_Access := Allocate (Source'Length); + DR : Shared_Wide_String_Access; + begin - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_Wide_String; function To_Unbounded_Wide_String (Length : Natural) return Unbounded_Wide_String is - DR : constant Shared_Wide_String_Access := Allocate (Length); + DR : Shared_Wide_String_Access; + begin - DR.Last := Length; + if Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_Wide_String; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb index b71f71d5ff3..bf2ed256334 100644 --- a/gcc/ada/a-stzunb-shared.adb +++ b/gcc/ada/a-stzunb-shared.adb @@ -1631,19 +1631,37 @@ package body Ada.Strings.Wide_Wide_Unbounded is function To_Unbounded_Wide_Wide_String (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String is - DR : constant Shared_Wide_Wide_String_Access := Allocate (Source'Length); + DR : Shared_Wide_Wide_String_Access; + begin - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_Wide_Wide_String; function To_Unbounded_Wide_Wide_String (Length : Natural) return Unbounded_Wide_Wide_String is - DR : constant Shared_Wide_Wide_String_Access := Allocate (Length); + DR : Shared_Wide_Wide_String_Access; + begin - DR.Last := Length; + if Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + return (AF.Controlled with Reference => DR); end To_Unbounded_Wide_Wide_String; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 36a11899618..5df6f3d440a 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2501,7 +2501,7 @@ win32_wait (int *status) pidl = (int *) xmalloc (sizeof (int) * hl_len); memmove (pidl, PID_LIST, sizeof (int) * hl_len); #else - /* Note that index 0 contains the event hanlde that is signaled when the + /* Note that index 0 contains the event handle that is signaled when the process list has changed */ hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len + 1); hl[0] = ProcListEvt; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a833a0ff8af..86b46c60e72 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6473,11 +6473,8 @@ package body Exp_Util is -- SS_Release; -- Temp is gone at this point, bounds of S are -- -- non existent. - -- The bounds are kept as variables rather than constants because - -- this prevents spurious optimizations down the line. - -- Generate: - -- Low_Bound : Base_Type (Index_Typ) := E'First (J); + -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J); Low_Bound := Make_Temporary (Loc, 'B'); Insert_Action (E, @@ -6485,6 +6482,7 @@ package body Exp_Util is Defining_Identifier => Low_Bound, Object_Definition => New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), + Constant_Present => True, Expression => Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_No_Checks (E), @@ -6493,7 +6491,7 @@ package body Exp_Util is Make_Integer_Literal (Loc, J))))); -- Generate: - -- High_Bound : Base_Type (Index_Typ) := E'Last (J); + -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J); High_Bound := Make_Temporary (Loc, 'B'); Insert_Action (E, @@ -6501,6 +6499,7 @@ package body Exp_Util is Defining_Identifier => High_Bound, Object_Definition => New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc), + Constant_Present => True, Expression => Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr_No_Checks (E), diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 94125173515..3a10c9cb929 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -976,11 +976,17 @@ package body GNAT.Sockets is Raise_Host_Error (Integer (Err)); end if; - return H : constant Host_Entry_Type := - To_Host_Entry (Res'Unchecked_Access) - do - Netdb_Unlock; - end return; + begin + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + exception + when others => + Netdb_Unlock; + raise; + end; end Get_Host_By_Address; ---------------------- @@ -2420,9 +2426,13 @@ package body GNAT.Sockets is Aliases_Count, Addresses_Count : Natural; -- H_Length is not used because it is currently only ever set to 4, as - -- H_Addrtype is always AF_INET. + -- we only handle the case of H_Addrtype being AF_INET. begin + if Hostent_H_Addrtype (E) /= SOSC.AF_INET then + Raise_Socket_Error (SOSC.EPFNOSUPPORT); + end if; + Aliases_Count := 0; while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop Aliases_Count := Aliases_Count + 1; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index d6f3dde7349..3915c30e7ed 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -847,37 +847,49 @@ package body Repinfo is Comp := First_Component_Or_Discriminant (Ent); while Present (Comp) loop - Get_Decoded_Name_String (Chars (Comp)); - Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); - Cfbit := Component_Bit_Offset (Comp); + -- Skip discriminant in unchecked union (since it is not there!) - if Rep_Not_Constant (Cfbit) then - UI_Image_Length := 2; + if Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Ent) + then + null; + + -- All other cases else - -- Complete annotation in case not done + Get_Decoded_Name_String (Chars (Comp)); + Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); - Set_Normalized_Position (Comp, Cfbit / SSU); - Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + Cfbit := Component_Bit_Offset (Comp); - Sunit := Cfbit / SSU; - UI_Image (Sunit); + if Rep_Not_Constant (Cfbit) then + UI_Image_Length := 2; + + else + -- Complete annotation in case not done + + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + + Sunit := Cfbit / SSU; + UI_Image (Sunit); + end if; + + -- If the record is not packed, then we know that all fields + -- whose position is not specified have a starting normalized + -- bit position of zero. + + if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) + then + Set_Normalized_First_Bit (Comp, Uint_0); + end if; + + Max_Suni_Length := + Natural'Max (Max_Suni_Length, UI_Image_Length); end if; - -- If the record is not packed, then we know that all fields whose - -- position is not specified have a starting normalized bit position - -- of zero. - - if Unknown_Normalized_First_Bit (Comp) - and then not Is_Packed (Ent) - then - Set_Normalized_First_Bit (Comp, Uint_0); - end if; - - Max_Suni_Length := - Natural'Max (Max_Suni_Length, UI_Image_Length); - Next_Component_Or_Discriminant (Comp); end loop; @@ -885,6 +897,17 @@ package body Repinfo is Comp := First_Component_Or_Discriminant (Ent); while Present (Comp) loop + + -- Skip discriminant in unchecked union (since it is not there!) + + if Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Ent) + then + goto Continue; + end if; + + -- All other cases + declare Esiz : constant Uint := Esize (Comp); Bofs : constant Uint := Component_Bit_Offset (Comp); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 42e64b1287f..a0dd0be46d3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3555,7 +3555,7 @@ package body Sem_Ch13 is if Base_Type (Typ) = Base_Type (Ent) or else (Is_Class_Wide_Type (Typ) - and then Typ = Class_Wide_Type (Base_Type (Ent))) + and then Typ = Class_Wide_Type (Base_Type (Ent))) then null; else @@ -3650,8 +3650,8 @@ package body Sem_Ch13 is (Ekind (Subp) = E_Function or else not Null_Present - (Specification - (Unit_Declaration_Node (Ultimate_Alias (Subp))))) + (Specification + (Unit_Declaration_Node (Ultimate_Alias (Subp))))) then Error_Msg_N ("stream subprogram for interface type " @@ -6600,6 +6600,12 @@ package body Sem_Ch13 is or else Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp)))) and then not Has_Warnings_Off (Rectype) + + -- Ignore discriminant in unchecked union, since it is + -- not there, and cannot have a component clause. + + and then (not Is_Unchecked_Union (Rectype) + or else Ekind (Comp) /= E_Discriminant) then Error_Msg_Sloc := Sloc (Comp); Error_Msg_NE diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 77eb48c36c5..5d8aa4f53be 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3163,12 +3163,17 @@ package body Sem_Eval is (Expr : Node_Id; Ent : out Entity_Id; Kind : out Character; - Cons : out Uint); + Cons : out Uint; + Orig : Boolean := True); -- Given an expression see if it is of the form given above, -- X [+/- K]. If so Ent is set to the entity in X, Kind is -- 'F','L','E' for 'First/'Last/simple entity, and Cons is -- the value of K. If the expression is not of the required -- form, Ent is set to Empty. + -- + -- Orig indicates whether Expr is the original expression + -- to consider, or if we are handling a sub-expression + -- (e.g. recursive call to Decompose_Expr). -------------------- -- Decompose_Expr -- @@ -3178,11 +3183,14 @@ package body Sem_Eval is (Expr : Node_Id; Ent : out Entity_Id; Kind : out Character; - Cons : out Uint) + Cons : out Uint; + Orig : Boolean := True) is Exp : Node_Id; begin + Ent := Empty; + if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then @@ -3206,18 +3214,29 @@ package body Sem_Eval is Nkind (Parent (Entity (Expr))) = N_Object_Declaration then Exp := Expression (Parent (Entity (Expr))); - Decompose_Expr (Exp, Ent, Kind, Cons); + Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False); -- If original expression includes an entity, create a -- reference to it for use below. if Present (Ent) then Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + else + return; end if; else - Exp := Expr; - Cons := Uint_0; + -- Only consider the case of X + 0 for a full + -- expression, and not when recursing, otherwise we + -- may end up with evaluating expressions not known + -- at compile time to 0. + + if Orig then + Exp := Expr; + Cons := Uint_0; + else + return; + end if; end if; -- At this stage Exp is set to the potential X @@ -3228,7 +3247,6 @@ package body Sem_Eval is elsif Attribute_Name (Exp) = Name_Last then Kind := 'L'; else - Ent := Empty; return; end if; @@ -3238,11 +3256,10 @@ package body Sem_Eval is Kind := 'E'; end if; - if Is_Entity_Name (Exp) and then Present (Entity (Exp)) + if Is_Entity_Name (Exp) + and then Present (Entity (Exp)) then Ent := Entity (Exp); - else - Ent := Empty; end if; end Decompose_Expr;