Commit c96c518f by Arnaud Charlet

[multiple changes]

2015-10-20  Jerome Lambourg  <lambourg@adacore.com>

	* init.c (__gnat_vxsim_error_handler): Completely disable on
	VxWorks-7 as the VSBs used to build gcc do not support vxsim
	architecture.

2015-10-20  Claire Dross  <dross@adacore.com>

	* a-cfdlli.ads, a-cfinve.ads, a-cofove.ads (Generic_Sorting): Explicit
	SPARK_Mode.
	* a-cfhase.ads, a-cforse.ads (Generic_Keys): Explicit SPARK_Mode.

2015-10-20  Tristan Gingold  <gingold@adacore.com>

	* exp_ch9.adb (Expand_N_Protected_Type_Declaration):
	Check for No_Implicit_Protected_Object_Allocations.
	* fe.h (Check_No_Implicit_Task_Alloc,
	Check_No_Implicit_Protected_Alloc): Define and declare.
	* restrict.ads, restrict.adb (Check_No_Implicit_Task_Alloc,
	Check_No_Implicit_Protected_Alloc): New procedures to check the
	restrictions.
	* s-rident.ads (No_Implicit_Task_Allocations)
	(No_Implicit_Protected_Object_Allocations): Declare new
	restrictions.

2015-10-20  Yannick Moy  <moy@adacore.com>

	* sem_res.adb (Resolve_Selected_Component): Only set flag
	when component is defined in a variant part.
	* sem_util.adb,
	* sem_util.ads (Is_Declared_Within_Variant): Promote local query
	as publicy visible one for use in Resolve_Selected_Component.

2015-10-20  Philippe Gil  <gil@adacore.com>

	* g-debpoo.adb: allow instrumented System.Memory to use Debug_Pool
	from foreign threads.
	* g-debpoo.adb (Print_Traceback): NEW print traceback if available
	added to support Stack_Trace_Depth = 0.
	(Print_Address): NEW print System.Address without no secondary
	stack use (Address_Image uses secondary stack)

From-SVN: r229058
parent 03a72cd3
2015-10-20 Jerome Lambourg <lambourg@adacore.com>
* init.c (__gnat_vxsim_error_handler): Completely disable on
VxWorks-7 as the VSBs used to build gcc do not support vxsim
architecture.
2015-10-20 Claire Dross <dross@adacore.com>
* a-cfdlli.ads, a-cfinve.ads, a-cofove.ads (Generic_Sorting): Explicit
SPARK_Mode.
* a-cfhase.ads, a-cforse.ads (Generic_Keys): Explicit SPARK_Mode.
2015-10-20 Tristan Gingold <gingold@adacore.com>
* exp_ch9.adb (Expand_N_Protected_Type_Declaration):
Check for No_Implicit_Protected_Object_Allocations.
* fe.h (Check_No_Implicit_Task_Alloc,
Check_No_Implicit_Protected_Alloc): Define and declare.
* restrict.ads, restrict.adb (Check_No_Implicit_Task_Alloc,
Check_No_Implicit_Protected_Alloc): New procedures to check the
restrictions.
* s-rident.ads (No_Implicit_Task_Allocations)
(No_Implicit_Protected_Object_Allocations): Declare new
restrictions.
2015-10-20 Yannick Moy <moy@adacore.com>
* sem_res.adb (Resolve_Selected_Component): Only set flag
when component is defined in a variant part.
* sem_util.adb,
* sem_util.ads (Is_Declared_Within_Variant): Promote local query
as publicy visible one for use in Resolve_Selected_Component.
2015-10-20 Philippe Gil <gil@adacore.com>
* g-debpoo.adb: allow instrumented System.Memory to use Debug_Pool
from foreign threads.
* g-debpoo.adb (Print_Traceback): NEW print traceback if available
added to support Stack_Trace_Depth = 0.
(Print_Address): NEW print System.Address without no secondary
stack use (Address_Image uses secondary stack)
2015-10-20 Yannick Moy <moy@adacore.com> 2015-10-20 Yannick Moy <moy@adacore.com>
* exp_ch9.adb (Expand_Entry_Barrier): Default initialize local variable * exp_ch9.adb (Expand_Entry_Barrier): Default initialize local variable
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
-- -- -- --
-- 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- --
...@@ -581,7 +581,7 @@ is ...@@ -581,7 +581,7 @@ is
-- Generic_Sorting -- -- Generic_Sorting --
--------------------- ---------------------
package body Generic_Sorting is package body Generic_Sorting with SPARK_Mode => Off is
--------------- ---------------
-- Is_Sorted -- -- Is_Sorted --
......
...@@ -299,7 +299,7 @@ is ...@@ -299,7 +299,7 @@ is
generic generic
with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is package Generic_Sorting with SPARK_Mode is
function Is_Sorted (Container : List) return Boolean with function Is_Sorted (Container : List) return Boolean with
Global => null; Global => null;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
-- -- -- --
-- 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- --
...@@ -1387,7 +1387,7 @@ is ...@@ -1387,7 +1387,7 @@ is
end; end;
end Vet; end Vet;
package body Generic_Keys is package body Generic_Keys with SPARK_Mode => Off is
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
......
...@@ -279,7 +279,7 @@ is ...@@ -279,7 +279,7 @@ is
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is package Generic_Keys with SPARK_Mode is
function Key (Container : Set; Position : Cursor) return Key_Type with function Key (Container : Set; Position : Cursor) return Key_Type with
Global => null; Global => null;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2014, Free Software Foundation, Inc. -- -- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
-- -- -- --
-- 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- --
...@@ -174,7 +174,7 @@ is ...@@ -174,7 +174,7 @@ is
-- Generic_Sorting -- -- Generic_Sorting --
--------------------- ---------------------
package body Generic_Sorting is package body Generic_Sorting with SPARK_Mode => Off is
function "<" (X, Y : Holder) return Boolean is (E (X) < E (Y)); function "<" (X, Y : Holder) return Boolean is (E (X) < E (Y));
package Def_Sorting is new Def.Generic_Sorting ("<"); package Def_Sorting is new Def.Generic_Sorting ("<");
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2014, Free Software Foundation, Inc. -- -- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -198,7 +198,7 @@ is ...@@ -198,7 +198,7 @@ is
generic generic
with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is package Generic_Sorting with SPARK_Mode is
function Is_Sorted (Container : Vector) return Boolean with function Is_Sorted (Container : Vector) return Boolean with
Global => null; Global => null;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
-- -- -- --
-- 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- --
...@@ -674,7 +674,7 @@ is ...@@ -674,7 +674,7 @@ is
-- Generic_Keys -- -- Generic_Keys --
------------------ ------------------
package body Generic_Keys is package body Generic_Keys with SPARK_Mode => Off is
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
......
...@@ -288,7 +288,7 @@ is ...@@ -288,7 +288,7 @@ is
with function "<" (Left, Right : Key_Type) return Boolean is <>; with function "<" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Keys is package Generic_Keys with SPARK_Mode is
function Equivalent_Keys (Left, Right : Key_Type) return Boolean with function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
Global => null; Global => null;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
-- -- -- --
-- 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- --
...@@ -355,7 +355,7 @@ is ...@@ -355,7 +355,7 @@ is
-- Generic_Sorting -- -- Generic_Sorting --
--------------------- ---------------------
package body Generic_Sorting is package body Generic_Sorting with SPARK_Mode => Off is
--------------- ---------------
-- Is_Sorted -- -- Is_Sorted --
......
...@@ -203,7 +203,7 @@ is ...@@ -203,7 +203,7 @@ is
generic generic
with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is package Generic_Sorting with SPARK_Mode is
function Is_Sorted (Container : Vector) return Boolean with function Is_Sorted (Container : Vector) return Boolean with
Global => null; Global => null;
......
...@@ -9140,6 +9140,8 @@ package body Exp_Ch9 is ...@@ -9140,6 +9140,8 @@ package body Exp_Ch9 is
-- is OK to miss this check in -gnatc mode. -- is OK to miss this check in -gnatc mode.
Check_Restriction (No_Implicit_Heap_Allocations, Priv); Check_Restriction (No_Implicit_Heap_Allocations, Priv);
Check_Restriction
(No_Implicit_Protected_Object_Allocations, Priv);
elsif Restriction_Active (No_Implicit_Heap_Allocations) then elsif Restriction_Active (No_Implicit_Heap_Allocations) then
if not Discriminated_Size (Defining_Identifier (Priv)) if not Discriminated_Size (Defining_Identifier (Priv))
...@@ -9162,6 +9164,34 @@ package body Exp_Ch9 is ...@@ -9162,6 +9164,34 @@ package body Exp_Ch9 is
& " restriction No_Implicit_Heap_Allocations??", & " restriction No_Implicit_Heap_Allocations??",
Priv, Prot_Typ); Priv, Prot_Typ);
end if; end if;
-- Likewise for No_Implicit_Protected_Object_Allocations
elsif Restriction_Active
(No_Implicit_Protected_Object_Allocations)
then
if not Discriminated_Size (Defining_Identifier (Priv))
then
-- Any object of the type will be non-static.
Error_Msg_N ("component has non-static size??", Priv);
Error_Msg_NE
("\creation of protected object of type& will"
& " violate restriction "
& "No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
else
-- Object will be non-static if discriminants are.
Error_Msg_NE
("creation of protected object of type& with "
& "non-static discriminants will violate "
& " restriction"
& " No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
end if;
end if; end if;
end if; end if;
......
...@@ -194,11 +194,15 @@ extern Boolean No_Strict_Aliasing_CP; ...@@ -194,11 +194,15 @@ extern Boolean No_Strict_Aliasing_CP;
#define No_Exception_Handlers_Set restrict__no_exception_handlers_set #define No_Exception_Handlers_Set restrict__no_exception_handlers_set
#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc #define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc
#define Check_No_Implicit_Task_Alloc restrict__check_no_implicit_task_alloc
#define Check_No_Implicit_Protected_Alloc restrict__check_no_implicit_protected_alloc
#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed #define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed
#define Check_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed #define Check_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed
extern Boolean No_Exception_Handlers_Set (void); extern Boolean No_Exception_Handlers_Set (void);
extern void Check_No_Implicit_Heap_Alloc (Node_Id); extern void Check_No_Implicit_Heap_Alloc (Node_Id);
extern void Check_No_Implicit_Task_Alloc (Node_Id);
extern void Check_No_Implicit_Protected_Alloc (Node_Id);
extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_Elaboration_Code_Allowed (Node_Id);
extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id);
......
...@@ -1902,7 +1902,8 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, ...@@ -1902,7 +1902,8 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED,
Raise_From_Signal_Handler (exception, msg); Raise_From_Signal_Handler (exception, msg);
} }
#if defined (__i386__) && !defined (VTHREADS) #if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR < 7
extern void extern void
__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc); __gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc);
...@@ -1939,7 +1940,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) ...@@ -1939,7 +1940,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
sigdelset (&mask, sig); sigdelset (&mask, sig);
sigprocmask (SIG_SETMASK, &mask, NULL); sigprocmask (SIG_SETMASK, &mask, NULL);
#if defined (__ARMEL__) || defined (__PPC__) || defined (__i386__) #if defined (__ARMEL__) || defined (__PPC__) || (defined (__i386__) && _WRS_VXWORKS_MAJOR < 7)
/* On certain targets, kernel mode, we process signals through a Call Frame /* On certain targets, kernel mode, we process signals through a Call Frame
Info trampoline, voiding the need for myriads of fallback_frame_state Info trampoline, voiding the need for myriads of fallback_frame_state
variants in the ZCX runtime. We have no simple way to distinguish ZCX variants in the ZCX runtime. We have no simple way to distinguish ZCX
...@@ -2039,7 +2040,7 @@ __gnat_install_handler (void) ...@@ -2039,7 +2040,7 @@ __gnat_install_handler (void)
trap_0_entry->inst_fourth = 0xa1480000; trap_0_entry->inst_fourth = 0xa1480000;
#endif #endif
#if defined (__i386__) && !defined (VTHREADS) #if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7
/* By experiment, found that sysModel () returns the following string /* By experiment, found that sysModel () returns the following string
prefix for vxsim when running on Linux and Windows. */ prefix for vxsim when running on Linux and Windows. */
model = sysModel (); model = sysModel ();
......
...@@ -285,6 +285,24 @@ package body Restrict is ...@@ -285,6 +285,24 @@ package body Restrict is
Check_Restriction (No_Implicit_Heap_Allocations, N); Check_Restriction (No_Implicit_Heap_Allocations, N);
end Check_No_Implicit_Heap_Alloc; end Check_No_Implicit_Heap_Alloc;
----------------------------------
-- Check_No_Implicit_Task_Alloc --
----------------------------------
procedure Check_No_Implicit_Task_Alloc (N : Node_Id) is
begin
Check_Restriction (No_Implicit_Task_Allocations, N);
end Check_No_Implicit_Task_Alloc;
---------------------------------------
-- Check_No_Implicit_Protected_Alloc --
---------------------------------------
procedure Check_No_Implicit_Protected_Alloc (N : Node_Id) is
begin
Check_Restriction (No_Implicit_Protected_Object_Allocations, N);
end Check_No_Implicit_Protected_Alloc;
----------------------------------- -----------------------------------
-- Check_Obsolescent_2005_Entity -- -- Check_Obsolescent_2005_Entity --
----------------------------------- -----------------------------------
......
...@@ -337,6 +337,15 @@ package Restrict is ...@@ -337,6 +337,15 @@ package Restrict is
-- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N). -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N).
-- Provided for easy use by back end, which has to check this restriction. -- Provided for easy use by back end, which has to check this restriction.
procedure Check_No_Implicit_Task_Alloc (N : Node_Id);
-- Equivalent to Check_Restriction (No_Implicit_Task_Allocations, N).
-- Provided for easy use by back end, which has to check this restriction.
procedure Check_No_Implicit_Protected_Alloc (N : Node_Id);
-- Equivalent to:
-- Check_Restriction (No_Implicit_Protected_Object_Allocations, N)
-- Provided for easy use by back end, which has to check this restriction.
procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id); procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id);
-- This routine checks if the entity E is one of the obsolescent entries -- This routine checks if the entity E is one of the obsolescent entries
-- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features -- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features
......
...@@ -119,6 +119,8 @@ package System.Rident is ...@@ -119,6 +119,8 @@ package System.Rident is
No_Implicit_Conditionals, -- GNAT No_Implicit_Conditionals, -- GNAT
No_Implicit_Dynamic_Code, -- GNAT No_Implicit_Dynamic_Code, -- GNAT
No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
No_Implicit_Task_Allocations, -- GNAT
No_Implicit_Protected_Object_Allocations, -- GNAT
No_Implicit_Loops, -- GNAT No_Implicit_Loops, -- GNAT
No_Initialize_Scalars, -- GNAT No_Initialize_Scalars, -- GNAT
No_Local_Allocators, -- (RM H.4(8)) No_Local_Allocators, -- (RM H.4(8))
......
...@@ -9883,6 +9883,8 @@ package body Sem_Res is ...@@ -9883,6 +9883,8 @@ package body Sem_Res is
and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Ekind_In (Entity (S), E_Component, E_Discriminant)
and then Present (Original_Record_Component (Entity (S))) and then Present (Original_Record_Component (Entity (S)))
and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Ekind (Original_Record_Component (Entity (S))) = E_Component
and then
Is_Declared_Within_Variant (Original_Record_Component (Entity (S)))
and then not Discriminant_Checks_Suppressed (T) and then not Discriminant_Checks_Suppressed (T)
and then not Init_Component and then not Init_Component
then then
......
...@@ -11125,6 +11125,17 @@ package body Sem_Util is ...@@ -11125,6 +11125,17 @@ package body Sem_Util is
end case; end case;
end Is_Declaration; end Is_Declaration;
--------------------------------
-- Is_Declared_Within_Variant --
--------------------------------
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
Comp_Decl : constant Node_Id := Parent (Comp);
Comp_List : constant Node_Id := Parent (Comp_Decl);
begin
return Nkind (Parent (Comp_List)) = N_Variant;
end Is_Declared_Within_Variant;
---------------------------------------------- ----------------------------------------------
-- Is_Dependent_Component_Of_Mutable_Object -- -- Is_Dependent_Component_Of_Mutable_Object --
---------------------------------------------- ----------------------------------------------
...@@ -11132,20 +11143,6 @@ package body Sem_Util is ...@@ -11132,20 +11143,6 @@ package body Sem_Util is
function Is_Dependent_Component_Of_Mutable_Object function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean (Object : Node_Id) return Boolean
is is
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp is declared within a variant part
--------------------------------
-- Is_Declared_Within_Variant --
--------------------------------
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
Comp_Decl : constant Node_Id := Parent (Comp);
Comp_List : constant Node_Id := Parent (Comp_Decl);
begin
return Nkind (Parent (Comp_List)) = N_Variant;
end Is_Declared_Within_Variant;
P : Node_Id; P : Node_Id;
Prefix_Type : Entity_Id; Prefix_Type : Entity_Id;
P_Aliased : Boolean := False; P_Aliased : Boolean := False;
......
...@@ -1262,6 +1262,9 @@ package Sem_Util is ...@@ -1262,6 +1262,9 @@ package Sem_Util is
function Is_Declaration (N : Node_Id) return Boolean; function Is_Declaration (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a declaration -- Determine whether arbitrary node N denotes a declaration
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True iff component Comp is declared within a variant part
function Is_Dependent_Component_Of_Mutable_Object function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean; (Object : Node_Id) return Boolean;
-- Returns True if Object is the name of a subcomponent that depends on -- Returns True if Object is the name of a subcomponent that depends on
......
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