Commit 5904016a by Arnaud Charlet

[multiple changes]

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_util.adb (Has_Full_Default_Initialization):
	Perform the test for the presence of pragma
	Default_Initial_Condition prior to the specialized type
	checks. Add a missing case where the lack of a pragma argument
	yields full default initialization.

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_res.adb (Resolve_Entity_Name): Do not check
	for elaboration issues when a variable appears as the name of
	an object renaming declaration as this constitutes an aliasing,
	not a read.

2015-11-18  Ed Schonberg  <schonberg@adacore.com>

	* checks.adb (Overlap_Check): An actual that is an aggregate
	cannot overlap with another actual, and no check should be
	generated for it.
	* targparm.ads: Fix typos.

2015-11-18  Pascal Obry  <obry@adacore.com>

	* adaint.c: Routine __gnat_killprocesstree only implemented on
	Linux and Windows.

2015-11-18  Pascal Obry  <obry@adacore.com>

	* g-ctrl_c.adb: Minor style fixes.

From-SVN: r230523
parent 287aa0ed
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
* sem_util.adb (Has_Full_Default_Initialization):
Perform the test for the presence of pragma
Default_Initial_Condition prior to the specialized type
checks. Add a missing case where the lack of a pragma argument
yields full default initialization.
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Entity_Name): Do not check
for elaboration issues when a variable appears as the name of
an object renaming declaration as this constitutes an aliasing,
not a read.
2015-11-18 Ed Schonberg <schonberg@adacore.com>
* checks.adb (Overlap_Check): An actual that is an aggregate
cannot overlap with another actual, and no check should be
generated for it.
* targparm.ads: Fix typos.
2015-11-18 Pascal Obry <obry@adacore.com>
* adaint.c: Routine __gnat_killprocesstree only implemented on
Linux and Windows.
2015-11-18 Pascal Obry <obry@adacore.com>
* g-ctrl_c.adb: Minor style fixes.
2015-11-18 Pascal Obry <obry@adacore.com> 2015-11-18 Pascal Obry <obry@adacore.com>
* adaint.c, s-os_lib.adb, s-os_lib.ads (Kill_Process_Tree): New. * adaint.c, s-os_lib.adb, s-os_lib.ads (Kill_Process_Tree): New.
......
...@@ -3259,7 +3259,11 @@ void __gnat_killprocesstree (int pid, int sig_num) ...@@ -3259,7 +3259,11 @@ void __gnat_killprocesstree (int pid, int sig_num)
/* kill process */ /* kill process */
__gnat_kill (pid, sig_num, 1); __gnat_kill (pid, sig_num, 1);
#else
#elif defined (__vxworks)
/* not implemented */
#elif defined (__linux__)
DIR *dir; DIR *dir;
struct dirent *d; struct dirent *d;
...@@ -3308,6 +3312,8 @@ void __gnat_killprocesstree (int pid, int sig_num) ...@@ -3308,6 +3312,8 @@ void __gnat_killprocesstree (int pid, int sig_num)
/* kill process */ /* kill process */
__gnat_kill (pid, sig_num, 1); __gnat_kill (pid, sig_num, 1);
#else
__gnat_kill (pid, sig_num, 1);
#endif #endif
/* Note on Solaris it is possible to read /proc/<PID>/status. /* Note on Solaris it is possible to read /proc/<PID>/status.
The 5th and 6th words are the pid and the 7th and 8th the ppid. The 5th and 6th words are the pid and the 7th and 8th the ppid.
......
...@@ -2359,9 +2359,19 @@ package body Checks is ...@@ -2359,9 +2359,19 @@ package body Checks is
-- Ensure that the actual is an object that is not passed by value. -- Ensure that the actual is an object that is not passed by value.
-- Elementary types are always passed by value, therefore actuals of -- Elementary types are always passed by value, therefore actuals of
-- such types cannot lead to aliasing. -- such types cannot lead to aliasing. An aggregate is an object in
-- Ada 2012, but an actual that is an aggregate cannot overlap with
-- another actual.
if Is_Object_Reference (Original_Actual (Actual_1)) if Nkind (Original_Actual (Actual_1)) = N_Aggregate
or else
(Nkind (Original_Actual (Actual_1)) = N_Qualified_Expression
and then Nkind (Expression (Original_Actual (Actual_1))) =
N_Aggregate)
then
null;
elsif Is_Object_Reference (Original_Actual (Actual_1))
and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1))) and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
then then
Actual_2 := Next_Actual (Actual_1); Actual_2 := Next_Actual (Actual_1);
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2002-2010, AdaCore -- -- Copyright (C) 2002-2015, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -39,11 +39,19 @@ package body GNAT.Ctrl_C is ...@@ -39,11 +39,19 @@ package body GNAT.Ctrl_C is
procedure C_Handler; procedure C_Handler;
pragma Convention (C, C_Handler); pragma Convention (C, C_Handler);
---------------
-- C_Handler --
---------------
procedure C_Handler is procedure C_Handler is
begin begin
Ada_Handler.all; Ada_Handler.all;
end C_Handler; end C_Handler;
---------------------
-- Install_Handler --
---------------------
procedure Install_Handler (Handler : Handler_Type) is procedure Install_Handler (Handler : Handler_Type) is
procedure Internal (Handler : C_Handler_Type); procedure Internal (Handler : C_Handler_Type);
pragma Import (C, Internal, "__gnat_install_int_handler"); pragma Import (C, Internal, "__gnat_install_int_handler");
......
...@@ -7231,9 +7231,13 @@ package body Sem_Res is ...@@ -7231,9 +7231,13 @@ package body Sem_Res is
& "(SPARK RM 7.1.3(12))", N); & "(SPARK RM 7.1.3(12))", N);
end if; end if;
-- Check possible elaboration issues with respect to variables -- Check for possible elaboration issues with respect to reads of
-- variables. The act of renaming the variable is not considered a
-- read as it simply establishes an alias.
if Ekind (E) = E_Variable then if Ekind (E) = E_Variable
and then Nkind (Par) /= N_Object_Renaming_Declaration
then
Check_Elab_Call (N); Check_Elab_Call (N);
end if; end if;
end if; end if;
......
...@@ -8852,9 +8852,41 @@ package body Sem_Util is ...@@ -8852,9 +8852,41 @@ package body Sem_Util is
------------------------------------- -------------------------------------
function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
Arg : Node_Id;
Comp : Entity_Id; Comp : Entity_Id;
Prag : Node_Id;
begin begin
-- A private type and its full view is fully default initialized when it
-- is subject to pragma Default_Initial_Condition without an argument or
-- with a non-null argument. Since any type may act as the full view of
-- a private type, this check must be performed prior to the specialized
-- tests below.
if Has_Default_Init_Cond (Typ)
or else Has_Inherited_Default_Init_Cond (Typ)
then
Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-- Pragma Default_Initial_Condition must be present if one of the
-- related entity flags is set.
pragma Assert (Present (Prag));
Arg := First (Pragma_Argument_Associations (Prag));
-- A non-null argument guarantees full default initialization
if Present (Arg) then
return Nkind (Arg) /= N_Null;
-- Otherwise the missing argument defaults the pragma to "True" which
-- is considered a non-null argument (see above).
else
return True;
end if;
end if;
-- A scalar type is fully default initialized if it is subject to aspect -- A scalar type is fully default initialized if it is subject to aspect
-- Default_Value. -- Default_Value.
...@@ -8911,20 +8943,6 @@ package body Sem_Util is ...@@ -8911,20 +8943,6 @@ package body Sem_Util is
elsif Is_Task_Type (Typ) then elsif Is_Task_Type (Typ) then
return True; return True;
end if;
-- A private type and by extension its full view is fully default
-- initialized if it is subject to pragma Default_Initial_Condition
-- with a non-null argument or inherits the pragma from a parent type.
-- Since any type can act as the full view of a private type, this check
-- is separated from the circuitry above.
if Has_Default_Init_Cond (Typ)
or else Has_Inherited_Default_Init_Cond (Typ)
then
return
Nkind (First (Pragma_Argument_Associations (Get_Pragma
(Typ, Pragma_Default_Initial_Condition)))) /= N_Null;
-- Otherwise the type is not fully default initialized -- Otherwise the type is not fully default initialized
......
...@@ -53,7 +53,7 @@ ...@@ -53,7 +53,7 @@
-- 1. Configuration pragmas, that must appear at the start of the file. -- 1. Configuration pragmas, that must appear at the start of the file.
-- Any such pragmas automatically apply to any unit compiled in the -- Any such pragmas automatically apply to any unit compiled in the
-- presence of this system file. Only a limited set of such pragmas -- presence of this system file. Only a limited set of such pragmas
-- may appear as documented in the corresponding section below, -- may appear as documented in the corresponding section below.
-- 2. Target parameters. These are boolean constants that are defined -- 2. Target parameters. These are boolean constants that are defined
-- in the private part of the package giving fixed information -- in the private part of the package giving fixed information
...@@ -107,7 +107,7 @@ package Targparm is ...@@ -107,7 +107,7 @@ package Targparm is
-- If a pragma Detect_Blocking appears, then the flag Opt.Detect_Blocking -- If a pragma Detect_Blocking appears, then the flag Opt.Detect_Blocking
-- is set to True. -- is set to True.
-- if a pragma Suppress_Exception_Locations appears, then the flag -- If a pragma Suppress_Exception_Locations appears, then the flag
-- Opt.Exception_Locations_Suppressed is set to True. -- Opt.Exception_Locations_Suppressed is set to True.
-- If a pragma Profile with a valid profile argument appears, then -- If a pragma Profile with a valid profile argument appears, then
......
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