mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 05:20:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-04-25  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch7.adb, einfo.ads, sem_prag.adb: Minor reformatting and typo
	correction.

2017-04-25  Yannick Moy  <moy@adacore.com>

	* sem_res.adb (Resolve_Comparison_Op): Do not
	attempt evaluation of relational operations inside assertions.

2017-04-25  Justin Squirek  <squirek@adacore.com>

	* exp_util.adb (Add_Interface_Invariants):
	Restored, code moved back from Build_Invariant_Procedure_Body.
	(Add_Parent_Invariants): Restored, code moved back from
	Build_Invariant_Procedure_Body.
	(Build_Invariant_Procedure_Body):
	Remove refactored calls and integrated code from
	Add_Parent_Invariants and Add_Interface_Invariants.

2017-04-25  Johannes Kanig  <kanig@adacore.com>

	* errout.adb (Output_Messages): Adjust computation of total
	errors
	* erroutc.adb (Error_Msg): In statistics counts, deal
	correctly with informational messages that are not warnings.
	* errutil.adb (Finalize): adjust computation of total errors.

2017-04-25  Arnaud Charlet  <charlet@adacore.com trojanek>

	* terminals.c (__gnat_terminate_pid): New.
	* g-exptty.ads (Terminate_Process): New. Update comments.

From-SVN: r247157
This commit is contained in:
Arnaud Charlet 2017-04-25 11:25:40 +02:00
parent d1eb8a82b2
commit ded462b0de
12 changed files with 315 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

@ -1,3 +1,36 @@
2017-04-25 Gary Dismukes <dismukes@adacore.com>
* exp_ch7.adb, einfo.ads, sem_prag.adb: Minor reformatting and typo
correction.
2017-04-25 Yannick Moy <moy@adacore.com>
* sem_res.adb (Resolve_Comparison_Op): Do not
attempt evaluation of relational operations inside assertions.
2017-04-25 Justin Squirek <squirek@adacore.com>
* exp_util.adb (Add_Interface_Invariants):
Restored, code moved back from Build_Invariant_Procedure_Body.
(Add_Parent_Invariants): Restored, code moved back from
Build_Invariant_Procedure_Body.
(Build_Invariant_Procedure_Body):
Remove refactored calls and integrated code from
Add_Parent_Invariants and Add_Interface_Invariants.
2017-04-25 Johannes Kanig <kanig@adacore.com>
* errout.adb (Output_Messages): Adjust computation of total
errors
* erroutc.adb (Error_Msg): In statistics counts, deal
correctly with informational messages that are not warnings.
* errutil.adb (Finalize): adjust computation of total errors.
2017-04-25 Arnaud Charlet <charlet@adacore.com trojanek>
* terminals.c (__gnat_terminate_pid): New.
* g-exptty.ads (Terminate_Process): New. Update comments.
2017-04-25 Arnaud Charlet <charlet@adacore.com>
* a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract.

16
gcc/ada/einfo.ads
View File

@ -3711,8 +3711,8 @@ package Einfo is
-- Original_Access_Type (Node28)
-- Defined in E_Access_Subprogram_Type entities. Set only if the access
-- type was generated by the expander as part of processing an access
-- to protected subprogram type. Points to the access to protected
-- type was generated by the expander as part of processing an access-
-- to-protected-subprogram type. Points to the access-to-protected-
-- subprogram type.
-- Original_Array_Type (Node21)
@ -4842,24 +4842,24 @@ package Einfo is
-- keyword present.
E_Access_Subprogram_Type,
-- An access to subprogram type, created by an access to subprogram
-- An access-to-subprogram type, created by an access-to-subprogram
-- declaration.
E_Access_Protected_Subprogram_Type,
-- An access to a protected subprogram, created by the corresponding
-- declaration. Values of such a type denote both a protected object
-- and a protected operation within, and have different compile-time
-- and run-time properties than other access to subprograms.
-- and run-time properties than other access-to-subprogram values.
E_Anonymous_Access_Protected_Subprogram_Type,
-- An anonymous access to protected subprogram type, created by an
-- access to subprogram declaration.
-- An anonymous access-to-protected-subprogram type, created by an
-- access-to-subprogram declaration.
E_Anonymous_Access_Subprogram_Type,
-- An anonymous access to subprogram type, created by an access to
-- An anonymous access-to-subprogram type, created by an access-to-
-- subprogram declaration, or generated for a current instance of
-- a type name appearing within a component definition that has an
-- anonymous access to subprogram type.
-- anonymous access-to-subprogram type.
E_Anonymous_Access_Type,
-- An anonymous access type created by an access parameter or access

2
gcc/ada/errout.adb
View File

@ -2105,7 +2105,7 @@ package body Errout is
if Warning_Mode = Treat_As_Error then
Total_Errors_Detected :=
Total_Errors_Detected + Warnings_Detected - Info_Messages;
Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := Info_Messages;
end if;
end Output_Messages;

13
gcc/ada/erroutc.adb
View File

@ -139,13 +139,16 @@ package body Erroutc is
-- Adjust error message count
if Errors.Table (D).Warn or else Errors.Table (D).Style then
Warnings_Detected := Warnings_Detected - 1;
if Errors.Table (D).Info then
Info_Messages := Info_Messages - 1;
if Errors.Table (D).Info then
Info_Messages := Info_Messages - 1;
if Errors.Table (D).Warn then
Warnings_Detected := Warnings_Detected - 1;
end if;
elsif Errors.Table (D).Warn or else Errors.Table (D).Style then
Warnings_Detected := Warnings_Detected - 1;
-- Note: we do not need to decrement Warnings_Treated_As_Errors
-- because this only gets incremented if we actually output the
-- message, which we won't do if we are deleting it here!
@ -240,7 +243,7 @@ package body Erroutc is
function Compilation_Errors return Boolean is
begin
return Total_Errors_Detected /= 0
or else (Warnings_Detected - Info_Messages /= 0
or else (Warnings_Detected /= 0
and then Warning_Mode = Treat_As_Error)
or else Warnings_Treated_As_Errors /= 0;
end Compilation_Errors;

2
gcc/ada/errutil.adb
View File

@ -588,7 +588,7 @@ package body Errutil is
if Warning_Mode = Treat_As_Error then
Total_Errors_Detected :=
Total_Errors_Detected + Warnings_Detected - Info_Messages;
Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := Info_Messages;
end if;

4
gcc/ada/exp_ch7.adb
View File

@ -486,14 +486,14 @@ package body Exp_Ch7 is
then
return False;
-- Do not consider an access type which return on the secondary stack
-- Do not consider an access type that returns on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return False;
-- Do not consider an access type which may never allocate an object
-- Do not consider an access type that can never allocate an object
elsif No_Pool_Assigned (Ptr_Typ) then
return False;

287
gcc/ada/exp_util.adb
View File

@ -1999,6 +1999,25 @@ package body Exp_Util is
-- Obj_Id denotes the entity of the _object formal parameter of the
-- invariant procedure. All created checks are added to list Checks.
procedure Add_Inherited_Invariant
(Full_Typ : Entity_Id;
Priv_Typ : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id);
-- Generate an invariant check for each inherited class-wide invariant
-- coming from all parent types of type T. Obj_Id denotes the entity of
-- the _object formal parameter of the invariant procedure. All created
-- checks are added to list Checks.
procedure Add_Interface_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id);
-- Generate an invariant check for each inherited class-wide invariant
-- coming from all interfaces implemented by type T. Obj_Id denotes the
-- entity of the _object formal parameter of the invariant procedure.
-- All created checks are added to list Checks.
procedure Add_Invariant_Check
(Prag : Node_Id;
Expr : Node_Id;
@ -2009,15 +2028,6 @@ package body Exp_Util is
-- is added to list Checks. Flag Inherited should be set when the pragma
-- is inherited from a parent or interface type.
procedure Add_Inherited_Invariant
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id);
-- Generate an invariant check for each inherited class-wide invariant
-- coming from all parent types of type T. Obj_Id denotes the entity of
-- the _object formal parameter of the invariant procedure. All created
-- checks are added to list Checks.
procedure Add_Own_Invariant
(T : Entity_Id;
Obj_Id : Entity_Id;
@ -2028,6 +2038,15 @@ package body Exp_Util is
-- invariant procedure. All created checks are added to list Checks.
-- Priv_Item denotes the first rep item of the private type.
procedure Add_Parent_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id);
-- Generate an invariant check for each inherited class-wide invariant
-- coming from all parent types of type T. Obj_Id denotes the entity of
-- the _object formal parameter of the invariant procedure. All created
-- checks are added to list Checks.
procedure Add_Record_Component_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
@ -2197,9 +2216,10 @@ package body Exp_Util is
-----------------------------
procedure Add_Inherited_Invariant
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id)
(Full_Typ : Entity_Id;
Priv_Typ : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id)
is
Arg1 : Node_Id;
Arg2 : Node_Id;
@ -2211,11 +2231,16 @@ package body Exp_Util is
-- instance of a type with the _object formal parameter
begin
if not Present (T) then
if not Present (Priv_Typ) and then not Present (Full_Typ) then
return;
end if;
Prag := First_Rep_Item (T);
if Present (Priv_Typ) then
Prag := First_Rep_Item (Priv_Typ);
else
Prag := First_Rep_Item (Full_Typ);
end if;
while Present (Prag) loop
if Nkind (Prag) = N_Pragma
and then Pragma_Name (Prag) = Name_Invariant
@ -2229,30 +2254,30 @@ package body Exp_Util is
-- Extract the arguments of the invariant pragma
Arg1 := First (Pragma_Argument_Associations (Prag));
Arg2 := Next (Arg1);
Arg2 := Get_Pragma_Arg (Next (Arg1));
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
-- The pragma applies to the partial view
if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then
Rep_Typ := Priv_Typ;
-- The pragma applies to the full view
elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then
Rep_Typ := Full_Typ;
-- Otherwise the pragma applies to a parent type in which case
-- it will be processed at a later stage by
-- Add_Parent_Invariants or Add_Interface_Invariants.
if Entity (Arg1) = T then
Rep_Typ := Entity (Arg1);
elsif Present (Full_View (T))
and then Entity (Arg1) = Full_View (T)
then
Rep_Typ := Full_View (T);
else
return;
end if;
-- Nothing to do when the caller requests the processing of
-- all inherited class-wide invariants, but the pragma does
-- not fall in this category.
-- Nothing to do when the caller requests the processing of all
-- inherited class-wide invariants, but the pragma does not
-- fall in this category.
if not Class_Present (Prag) then
return;
@ -2275,6 +2300,42 @@ package body Exp_Util is
end loop;
end Add_Inherited_Invariant;
------------------------------
-- Add_Interface_Invariants --
------------------------------
procedure Add_Interface_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id)
is
Iface_Elmt : Elmt_Id;
Ifaces : Elist_Id;
begin
-- Generate an invariant check for each inherited class-wide
-- invariant coming from all interfaces implemented by type T. Obj_Id
-- denotes the entity of the _object formal parameter of the
-- invariant procedure. All created checks are added to list Checks.
if Is_Tagged_Type (T) then
Collect_Interfaces (T, Ifaces);
-- Process the class-wide invariants of all implemented interfaces
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
Add_Inherited_Invariant
(Full_Typ => Node (Iface_Elmt),
Priv_Typ => Empty,
Obj_Id => Obj_Id,
Checks => Checks);
Next_Elmt (Iface_Elmt);
end loop;
end if;
end Add_Interface_Invariants;
-------------------------
-- Add_Invariant_Check --
-------------------------
@ -2355,6 +2416,80 @@ package body Exp_Util is
Produced_Check := True;
end Add_Invariant_Check;
---------------------------
-- Add_Parent_Invariants --
---------------------------
procedure Add_Parent_Invariants
(T : Entity_Id;
Obj_Id : Entity_Id;
Checks : in out List_Id)
is
Dummy_1 : Entity_Id;
Dummy_2 : Entity_Id;
Curr_Typ : Entity_Id;
-- The entity of the current type being examined
Full_Typ : Entity_Id;
-- The full view of Par_Typ
Par_Typ : Entity_Id;
-- The entity of the parent type
Priv_Typ : Entity_Id;
-- The partial view of Par_Typ
begin
-- Do not process array types because they cannot have true parent
-- types. This also prevents the generation of a duplicate invariant
-- check when the input type is an array base type because its Etype
-- denotes the first subtype, both of which share the same component
-- type.
if Is_Array_Type (T) then
return;
end if;
-- Climb the parent type chain
Curr_Typ := T;
loop
-- Do not consider subtypes as they inherit the invariants
-- from their base types.
Par_Typ := Base_Type (Etype (Curr_Typ));
-- Stop the climb once the root of the parent chain is
-- reached.
exit when Curr_Typ = Par_Typ;
-- Process the class-wide invariants of the parent type
Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
-- Process the elements of an array type
if Is_Array_Type (Full_Typ) then
Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
-- Process the components of a record type
elsif Ekind (Full_Typ) = E_Record_Type then
Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
end if;
Add_Inherited_Invariant
(Full_Typ => Full_Typ,
Priv_Typ => Priv_Typ,
Obj_Id => Obj_Id,
Checks => Checks);
Curr_Typ := Par_Typ;
end loop;
end Add_Parent_Invariants;
-----------------------
-- Add_Own_Invariant --
-----------------------
@ -2399,17 +2534,15 @@ package body Exp_Util is
-- Extract the arguments of the invariant pragma
Arg1 := First (Pragma_Argument_Associations (Prag));
Arg2 := Next (Arg1);
Arg2 := Get_Pragma_Arg (Next (Arg1));
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
Asp := Corresponding_Aspect (Prag);
Ploc := Sloc (Prag);
-- Otherwise the pragma applies to a parent type in which case
-- it will be processed at a later stage by
-- Add_Parent_Invariants or Add_Interface_Invariants.
-- Verify the pragma belongs to T, otherwise the pragma applies
-- to a parent type in which case it will be processed at a
-- later stage by Add_Parent_Invariants or
-- Add_Interface_Invariants.
if Entity (Arg1) /= T then
return;
@ -2724,10 +2857,7 @@ package body Exp_Util is
-- Local variables
Dummy_1 : Entity_Id;
Dummy_2 : Entity_Id;
Iface_Elmt : Elmt_Id;
Ifaces : Elist_Id;
Dummy : Entity_Id;
Mode : Ghost_Mode_Type;
Priv_Item : Node_Id;
Proc_Body : Node_Id;
@ -2799,7 +2929,7 @@ package body Exp_Util is
-- Obtain both views of the type
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
-- The caller requests a body for the partial invariant procedure
@ -2991,81 +3121,12 @@ package body Exp_Util is
-- Process the inherited class-wide invariants of all parent types.
-- This also handles any invariants on record components.
declare
Curr_Typ : Entity_Id;
-- The entity of the current type being examined
Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
Par_Full : Entity_Id;
-- The full view of Par_Typ
-- Process the inherited class-wide invariants of all implemented
-- interface types.
Par_Priv : Entity_Id;
-- The partial view of Par_Typ
Par_Typ : Entity_Id;
-- The entity of the parent type
begin
if not Is_Array_Type (Full_Typ) then
-- Climb the parent type chain
Curr_Typ := Full_Typ;
loop
-- Do not consider subtypes as they inherit the invariants
-- from their base types.
Par_Typ := Base_Type (Etype (Curr_Typ));
-- Stop the climb once the root of the parent chain is
-- reached.
exit when Curr_Typ = Par_Typ;
-- Process the class-wide invariants of the parent type
Get_Views (Par_Typ, Par_Priv, Par_Full, Dummy_1, Dummy_2);
-- Process the elements of an array type
if Is_Array_Type (Par_Full) then
Add_Array_Component_Invariants (Par_Full, Obj_Id, Stmts);
-- Process the components of a record type
elsif Ekind (Par_Full) = E_Record_Type then
Add_Record_Component_Invariants (Par_Full, Obj_Id, Stmts);
end if;
Add_Inherited_Invariant
(T => Par_Priv,
Obj_Id => Obj_Id,
Checks => Stmts);
Curr_Typ := Par_Typ;
end loop;
end if;
end;
-- Generate an invariant check for each inherited class-wide
-- invariant coming from all interfaces implemented by type T. Obj_Id
-- denotes the entity of the _object formal parameter of the
-- invariant procedure. All created checks are added to list Checks.
if Is_Tagged_Type (Full_Typ) then
Collect_Interfaces (Full_Typ, Ifaces);
-- Process the class-wide invariants of all implemented interfaces
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
Add_Inherited_Invariant
(T => Node (Iface_Elmt),
Obj_Id => Obj_Id,
Checks => Stmts);
Next_Elmt (Iface_Elmt);
end loop;
end if;
Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
end if;
End_Scope;

13
gcc/ada/g-exptty.adb
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2014, AdaCore --
-- Copyright (C) 2000-2016, AdaCore --
-- --
-- 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- --
@ -147,6 +147,17 @@ package body GNAT.Expect.TTY is
Internal (Pid);
end Interrupt;
-----------------------
-- Terminate_Process --
-----------------------
procedure Terminate_Process (Pid : Integer) is
procedure Internal (Pid : Integer);
pragma Import (C, Internal, "__gnat_terminate_pid");
begin
Internal (Pid);
end Terminate_Process;
-----------------------
-- Pseudo_Descriptor --
-----------------------

10
gcc/ada/g-exptty.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2011, AdaCore --
-- Copyright (C) 2000-2016, AdaCore --
-- --
-- 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- --
@ -64,7 +64,13 @@ package GNAT.Expect.TTY is
-- GNAT.TTY.Close_TTY.
procedure Interrupt (Pid : Integer);
-- Interrupt a process given its pid
-- Interrupt a process given its pid.
-- This is equivalent to sending a ctrl-c event, or kill -SIGINT.
procedure Terminate_Process (Pid : Integer);
-- Terminate abruptly a process given its pid.
-- This is equivalent to kill -SIGKILL under unix, or TerminateProcess
-- under Windows.
overriding procedure Send
(Descriptor : in out TTY_Process_Descriptor;

2
gcc/ada/sem_prag.adb
View File

@ -17922,7 +17922,7 @@ package body Sem_Prag is
if Is_Library_Level_Entity (Typ) then
null;
-- Qietly ignore an access-to-object type originally declared
-- Quietly ignore an access-to-object type originally declared
-- at the library level within a generic, but instantiated at
-- a non-library level. As a result the access-to-object type
-- "loses" its No_Heap_Finalization property.

13
gcc/ada/sem_res.adb
View File

@ -6898,11 +6898,16 @@ package body Sem_Res is
N, Etype (L));
end if;
-- Evaluate the relation (note we do this after the above check since
-- this Eval call may change N to True/False.
Analyze_Dimension (N);
Eval_Relational_Op (N);
-- Evaluate the relation (note we do this after the above check since
-- this Eval call may change N to True/False. Skip this evaluation
-- inside assertions, in order to keep assertions as written by users
-- for tools that rely on these, e.g. GNATprove for loop invariants.
if In_Assertion_Expr = 0 then
Eval_Relational_Op (N);
end if;
end Resolve_Comparison_Op;
-----------------------------------------

58
gcc/ada/terminals.c
View File

@ -89,6 +89,12 @@ __gnat_terminate_process (void *desc ATTRIBUTE_UNUSED)
return -1;
}
int
__gnat_terminate_pid (int pid ATTRIBUTE_UNUSED)
{
return -1;
}
int
__gnat_tty_fd (void* t ATTRIBUTE_UNUSED)
{
@ -962,6 +968,47 @@ __gnat_terminate_process (struct TTY_Process* p)
return 0;
}
typedef struct {
DWORD dwProcessId;
HANDLE hwnd;
} pid_struct;
static BOOL CALLBACK
find_process_handle (HWND hwnd, pid_struct * ps)
{
DWORD thread_id;
DWORD process_id;
thread_id = GetWindowThreadProcessId (hwnd, &process_id);
if (process_id == ps->dwProcessId)
{
ps->hwnd = hwnd;
return FALSE;
}
/* keep looking */
return TRUE;
}
int
__gnat_terminate_pid (int pid)
{
pid_struct ps;
ps.dwProcessId = pid;
ps.hwnd = 0;
EnumWindows ((WNDENUMPROC) find_process_handle, (LPARAM) &ps);
if (ps.hwnd)
{
if (!TerminateProcess (ps.hwnd, 1))
return -1;
else
return 0;
}
return -1;
}
/* wait for process pid to terminate and return the process status. This
implementation is different from the adaint.c one for Windows as it uses
the Win32 API instead of the C one. */
@ -1500,6 +1547,17 @@ int __gnat_terminate_process (pty_desc *desc)
return kill (desc->child_pid, SIGKILL);
}
/* __gnat_terminate_pid - kill a process
*
* PARAMETERS
* pid unix process id
*/
int
__gnat_terminate_pid (int pid)
{
return kill (pid, SIGKILL);
}
/* __gnat_tty_waitpid - wait for the child process to die
*
* PARAMETERS