Commit ded462b0 by Arnaud Charlet

[multiple changes]

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
parent d1eb8a82
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.
......
......@@ -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
......
......@@ -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;
......
......@@ -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;
......
......@@ -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;
......
......@@ -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;
......
......@@ -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- --
......@@ -148,6 +148,17 @@ package body GNAT.Expect.TTY is
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 --
-----------------------
......
......@@ -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;
......
......@@ -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.
......@@ -6898,11 +6898,16 @@ package body Sem_Res is
N, Etype (L));
end if;
Analyze_Dimension (N);
-- Evaluate the relation (note we do this after the above check since
-- this Eval call may change N to True/False.
-- 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.
Analyze_Dimension (N);
Eval_Relational_Op (N);
if In_Assertion_Expr = 0 then
Eval_Relational_Op (N);
end if;
end Resolve_Comparison_Op;
-----------------------------------------
......
......@@ -90,6 +90,12 @@ __gnat_terminate_process (void *desc ATTRIBUTE_UNUSED)
}
int
__gnat_terminate_pid (int pid ATTRIBUTE_UNUSED)
{
return -1;
}
int
__gnat_tty_fd (void* t ATTRIBUTE_UNUSED)
{
return -1;
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment