+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>
* exp_ch9.adb (Expand_Entry_Barrier): Default initialize local variable
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Generic_Sorting --
---------------------
- package body Generic_Sorting is
+ package body Generic_Sorting with SPARK_Mode => Off is
---------------
-- Is_Sorted --
generic
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
Global => null;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
end;
end Vet;
- package body Generic_Keys is
+ package body Generic_Keys with SPARK_Mode => Off is
-----------------------
-- Local Subprograms --
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
Global => null;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- 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));
package Def_Sorting is new Def.Generic_Sorting ("<");
-- --
-- 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 --
-- GNAT. The copyright notice above, and the license provisions that follow --
generic
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
Global => null;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Generic_Keys --
------------------
- package body Generic_Keys is
+ package body Generic_Keys with SPARK_Mode => Off is
-----------------------
-- Local Subprograms --
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
Global => null;
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Generic_Sorting --
---------------------
- package body Generic_Sorting is
+ package body Generic_Sorting with SPARK_Mode => Off is
---------------
-- Is_Sorted --
generic
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
Global => null;
-- is OK to miss this check in -gnatc mode.
Check_Restriction (No_Implicit_Heap_Allocations, Priv);
+ Check_Restriction
+ (No_Implicit_Protected_Object_Allocations, Priv);
elsif Restriction_Active (No_Implicit_Heap_Allocations) then
if not Discriminated_Size (Defining_Identifier (Priv))
& " restriction No_Implicit_Heap_Allocations??",
Priv, Prot_Typ);
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;
#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_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_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed
extern Boolean No_Exception_Handlers_Set (void);
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_Implicit_Dynamic_Code_Allowed (Node_Id);
-- Wrapper for Put_Line that ensures we always write to stdout instead of
-- the current output file defined in GNAT.IO.
+ procedure Print_Traceback
+ (Output_File : File_Type;
+ Prefix : String;
+ Traceback : Traceback_Htable_Elem_Ptr);
+ -- Output Prefix & Traceback & EOL.
+ -- Print nothing if Traceback is null.
+
+ procedure Print_Address (File : File_Type; Addr : Address);
+ -- Output System.Address without using secondary stack.
+ -- When System.Memory uses Debug_Pool, secondary stack cannot be used
+ -- during Allocate calls, as some Allocate calls are done to
+ -- register/initialize a secondary stack for a foreign thread.
+ -- During these calls, the secondary stack is not available yet.
+
package Validity is
function Is_Handled (Storage : System.Address) return Boolean;
pragma Inline (Is_Handled);
end if;
end Output_File;
+ -------------------
+ -- Print_Address --
+ -------------------
+
+ procedure Print_Address (File : File_Type; Addr : Address) is
+ type My_Address is mod Memory_Size;
+ function To_My_Address is new Ada.Unchecked_Conversion
+ (System.Address, My_Address);
+ begin
+ Put (File, My_Address'Image (To_My_Address (Addr)));
+ end Print_Address;
+
--------------
-- Put_Line --
--------------
procedure Print (Tr : Tracebacks_Array) is
begin
for J in Tr'Range loop
- Put (File, "0x" & Address_Image (PC_For (Tr (J))) & ' ');
+ Print_Address (File, PC_For (Tr (J)));
+ Put (File, ' ');
end loop;
Put (File, ASCII.LF);
end Print;
if Pool.Low_Level_Traces then
Put (Output_File (Pool),
"info: Allocated"
- & Storage_Count'Image (Size_In_Storage_Elements)
- & " bytes at 0x" & Address_Image (Storage_Address)
- & " (physically:"
- & Storage_Count'Image (Local_Storage_Array'Length)
- & " bytes at 0x" & Address_Image (P.all'Address)
- & "), at ");
+ & Storage_Count'Image (Size_In_Storage_Elements)
+ & " bytes at ");
+ Print_Address (Output_File (Pool), Storage_Address);
+ Put (Output_File (Pool),
+ " (physically:"
+ & Storage_Count'Image (Local_Storage_Array'Length)
+ & " bytes at ");
+ Print_Address (Output_File (Pool), P.all'Address);
+ Put (Output_File (Pool),
+ "), at ");
Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
Allocate_Label'Address,
Code_Address_For_Deallocate_End);
Next := Header.Next;
if Pool.Low_Level_Traces then
- Put_Line
+ Put
(Output_File (Pool),
"info: Freeing physical memory "
- & Storage_Count'Image
+ & Storage_Count'Image
((abs Header.Block_Size) + Extra_Allocation)
- & " bytes at 0x"
- & Address_Image (Header.Allocation_Address));
+ & " bytes at ");
+ Print_Address (Output_File (Pool),
+ Header.Allocation_Address);
+ Put_Line (Output_File (Pool), "");
end if;
if System_Memory_Debug_Pool_Enabled then
end Get_Size;
+ ---------------------
+ -- Print_Traceback --
+ ---------------------
+
+ procedure Print_Traceback
+ (Output_File : File_Type;
+ Prefix : String;
+ Traceback : Traceback_Htable_Elem_Ptr) is
+ begin
+ if Traceback /= null then
+ Put (Output_File, Prefix);
+ Put_Line (Output_File, 0, Traceback.Traceback);
+ end if;
+ end Print_Traceback;
+
----------------
-- Deallocate --
----------------
Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
- Put (Output_File (Pool), " Memory already deallocated at ");
- Put_Line
- (Output_File (Pool), 0,
- To_Traceback (Header.Dealloc_Traceback).Traceback);
- Put (Output_File (Pool), " Memory was allocated at ");
- Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
+ Print_Traceback (Output_File (Pool),
+ " Memory already deallocated at ",
+ To_Traceback (Header.Dealloc_Traceback));
+ Print_Traceback (Output_File (Pool), " Memory was allocated at ",
+ Header.Alloc_Traceback);
end if;
else
Put (Output_File (Pool),
"info: Deallocated"
& Storage_Count'Image (Header.Block_Size)
- & " bytes at 0x" & Address_Image (Storage_Address)
- & " (physically"
+ & " bytes at ");
+ Print_Address (Output_File (Pool), Storage_Address);
+ Put (Output_File (Pool),
+ " (physically"
& Storage_Count'Image (Header.Block_Size + Extra_Allocation)
- & " bytes at 0x" & Address_Image (Header.Allocation_Address)
- & "), at ");
+ & " bytes at ");
+ Print_Address (Output_File (Pool), Header.Allocation_Address);
+ Put (Output_File (Pool), "), at ");
+
Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
- Put (Output_File (Pool), " Memory was allocated at ");
- Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback);
+ Print_Traceback (Output_File (Pool), " Memory was allocated at ",
+ Header.Alloc_Traceback);
end if;
-- Remove this block from the list of used blocks
(Output_File (Pool), Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Code_Address_For_Dereference_End);
- Put (Output_File (Pool), " First deallocation at ");
- Put_Line
- (Output_File (Pool),
- 0, To_Traceback (Header.Dealloc_Traceback).Traceback);
- Put (Output_File (Pool), " Initial allocation at ");
- Put_Line
- (Output_File (Pool),
- 0, Header.Alloc_Traceback.Traceback);
+ Print_Traceback (Output_File (Pool), " First deallocation at ",
+ To_Traceback (Header.Dealloc_Traceback));
+ Print_Traceback (Output_File (Pool), " Initial allocation at ",
+ Header.Alloc_Traceback);
end if;
end if;
end if;
Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
- for T in Header.Alloc_Traceback.Traceback'Range loop
- Put ("0x" & Address_Image
- (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
- end loop;
+ if Header.Alloc_Traceback /= null then
+ for T in Header.Alloc_Traceback.Traceback'Range loop
+ Put ("0x" & Address_Image
+ (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
+ end loop;
+ end if;
Put_Line ("");
Current := Header.Next;
else
Header := Header_Of (Storage);
- Put_Line (Standard_Output, "0x" & Address_Image (A)
- & " allocated at:");
- Put_Line (Standard_Output, 0, Header.Alloc_Traceback.Traceback);
+ Print_Address (Standard_Output, A);
+ Put_Line (Standard_Output, " allocated at:");
+ Print_Traceback (Standard_Output, "", Header.Alloc_Traceback);
if To_Traceback (Header.Dealloc_Traceback) /= null then
- Put_Line (Standard_Output, "0x" & Address_Image (A)
- & " logically freed memory, deallocated at:");
- Put_Line
- (Standard_Output, 0,
- To_Traceback (Header.Dealloc_Traceback).Traceback);
+ Print_Address (Standard_Output, A);
+ Put_Line (Standard_Output,
+ " logically freed memory, deallocated at:");
+ Print_Traceback (Standard_Output, "",
+ To_Traceback (Header.Dealloc_Traceback));
end if;
end if;
end Print_Pool;
Actual_Size := size_t (Header.Block_Size);
Tracebk := Header.Alloc_Traceback.Traceback;
- Num_Calls := Tracebk'Length;
- -- (Code taken from memtrack.adb in GNAT's sources)
+ if Header.Alloc_Traceback /= null then
+ Num_Calls := Tracebk'Length;
- -- Logs allocation call using the format:
+ -- (Code taken from memtrack.adb in GNAT's sources)
- -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+ -- Logs allocation call using the format:
- fputc (Character'Pos ('A'), File);
- fwrite (Current'Address, Address_Size, 1, File);
- fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
- File);
- fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1,
- File);
- fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
- File);
+ -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
- for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
- declare
- Ptr : System.Address := PC_For (Tracebk (J));
- begin
- fwrite (Ptr'Address, Address_Size, 1, File);
- end;
- end loop;
+ fputc (Character'Pos ('A'), File);
+ fwrite (Current'Address, Address_Size, 1, File);
+ fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements,
+ 1, File);
+ fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements,
+ 1, File);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ File);
+
+ for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+ declare
+ Ptr : System.Address := PC_For (Tracebk (J));
+ begin
+ fwrite (Ptr'Address, Address_Size, 1, File);
+ end;
+ end loop;
+
+ end if;
Current := Header.Next;
end loop;
Raise_From_Signal_Handler (exception, msg);
}
-#if defined (__i386__) && !defined (VTHREADS)
+#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR < 7
+
extern void
__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc);
sigdelset (&mask, sig);
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
Info trampoline, voiding the need for myriads of fallback_frame_state
variants in the ZCX runtime. We have no simple way to distinguish ZCX
trap_0_entry->inst_fourth = 0xa1480000;
#endif
-#if defined (__i386__) && !defined (VTHREADS)
+#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7
/* By experiment, found that sysModel () returns the following string
prefix for vxsim when running on Linux and Windows. */
model = sysModel ();
Check_Restriction (No_Implicit_Heap_Allocations, N);
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 --
-----------------------------------
-- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N).
-- 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);
-- This routine checks if the entity E is one of the obsolescent entries
-- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features
No_Implicit_Conditionals, -- GNAT
No_Implicit_Dynamic_Code, -- GNAT
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_Initialize_Scalars, -- GNAT
No_Local_Allocators, -- (RM H.4(8))
and then Ekind_In (Entity (S), E_Component, E_Discriminant)
and then Present (Original_Record_Component (Entity (S)))
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 Init_Component
then
end case;
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 --
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean
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;
Prefix_Type : Entity_Id;
P_Aliased : Boolean := False;
function Is_Declaration (N : Node_Id) return Boolean;
-- 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
(Object : Node_Id) return Boolean;
-- Returns True if Object is the name of a subcomponent that depends on
projects / gcc.git / commitdiff