mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 05:30:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-11-20  Thomas Quinot  <quinot@adacore.com>

	* g-socket.adb (To_Host_Entry): Guard against case of a
	non-AF_INET entry.

2014-11-20  Vadim Godunko  <godunko@adacore.com>

	* 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  <moy@adacore.com>

	* 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  <charlet@adacore.com>

	* 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  <dewar@adacore.com>

	* 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.

From-SVN: r217861
This commit is contained in:
Arnaud Charlet 2014-11-20 15:37:41 +01:00
parent f92d99c60b
commit 3fbbbd1e87
16 changed files with 212 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -1,3 +1,38 @@
2014-11-20 Thomas Quinot <quinot@adacore.com>
* g-socket.adb (To_Host_Entry): Guard against case of a
non-AF_INET entry.
2014-11-20 Vadim Godunko <godunko@adacore.com>
* 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 <moy@adacore.com>
* 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 <charlet@adacore.com>
* 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 <dewar@adacore.com>
* 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 <godunko@adacore.com>
* a-strunb-shared.adb, a-stwiun-shared.adb, a-stzunb-shared.adb

1
gcc/ada/a-cfhama.adb
View File

@ -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 --

1
gcc/ada/a-cfhase.adb
View File

@ -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 --

1
gcc/ada/a-cfinve.adb
View File

@ -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;

1
gcc/ada/a-cforma.adb
View File

@ -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 --

1
gcc/ada/a-cforse.adb
View File

@ -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 --

1
gcc/ada/a-cofove.adb
View File

@ -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

28
gcc/ada/a-strunb-shared.adb
View File

@ -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;

28
gcc/ada/a-stwiun-shared.adb
View File

@ -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;

28
gcc/ada/a-stzunb-shared.adb
View File

@ -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;

2
gcc/ada/adaint.c
View File

@ -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;

9
gcc/ada/exp_util.adb
View File

@ -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),

22
gcc/ada/g-socket.adb
View File

@ -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;

69
gcc/ada/repinfo.adb
View File

@ -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);

12
gcc/ada/sem_ch13.adb
View File

@ -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

35
gcc/ada/sem_eval.adb
View File

@ -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;