From c96c518f9de243e868f8f18c00819cae87fcdd2c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 Oct 2015 14:09:17 +0200 Subject: [PATCH] [multiple changes] 2015-10-20 Jerome Lambourg * 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 * 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 * 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 * 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 * 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 --- gcc/ada/ChangeLog | 42 ++++++++++ gcc/ada/a-cfdlli.adb | 4 +- gcc/ada/a-cfdlli.ads | 2 +- gcc/ada/a-cfhase.adb | 4 +- gcc/ada/a-cfhase.ads | 2 +- gcc/ada/a-cfinve.adb | 4 +- gcc/ada/a-cfinve.ads | 4 +- gcc/ada/a-cforse.adb | 4 +- gcc/ada/a-cforse.ads | 2 +- gcc/ada/a-cofove.adb | 4 +- gcc/ada/a-cofove.ads | 2 +- gcc/ada/exp_ch9.adb | 30 ++++++++ gcc/ada/fe.h | 4 + gcc/ada/g-debpoo.adb | 177 ++++++++++++++++++++++++++++--------------- gcc/ada/init.c | 7 +- gcc/ada/restrict.adb | 18 +++++ gcc/ada/restrict.ads | 9 +++ gcc/ada/s-rident.ads | 2 + gcc/ada/sem_res.adb | 2 + gcc/ada/sem_util.adb | 25 +++--- gcc/ada/sem_util.ads | 3 + 21 files changed, 256 insertions(+), 95 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fda8e8bbf93..65e6c4c932d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2015-10-20 Jerome Lambourg + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 * exp_ch9.adb (Expand_Entry_Barrier): Default initialize local variable diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 2e8676b4495..7b19dd65b36 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -581,7 +581,7 @@ is -- Generic_Sorting -- --------------------- - package body Generic_Sorting is + package body Generic_Sorting with SPARK_Mode => Off is --------------- -- Is_Sorted -- diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index f4a25861bff..e0b96a3bd2a 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -299,7 +299,7 @@ is 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; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 8d73a2c385c..ac2ea61adb4 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1387,7 +1387,7 @@ is end; end Vet; - package body Generic_Keys is + package body Generic_Keys with SPARK_Mode => Off is ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index e0d210e5334..0c43cf255f3 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -279,7 +279,7 @@ is 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; diff --git a/gcc/ada/a-cfinve.adb b/gcc/ada/a-cfinve.adb index f088b9ed118..da23a441c33 100644 --- a/gcc/ada/a-cfinve.adb +++ b/gcc/ada/a-cfinve.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -174,7 +174,7 @@ is -- 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 ("<"); diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads index 7559df6e4b5..2fef4af7856 100644 --- a/gcc/ada/a-cfinve.ads +++ b/gcc/ada/a-cfinve.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -198,7 +198,7 @@ is 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; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index e1203215cc9..2b09018ab57 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -674,7 +674,7 @@ is -- Generic_Keys -- ------------------ - package body Generic_Keys is + package body Generic_Keys with SPARK_Mode => Off is ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index a69aa4f3de4..a3cbae1b852 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -288,7 +288,7 @@ 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 Global => null; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index ef37cc0226e..c713bbca033 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -355,7 +355,7 @@ is -- Generic_Sorting -- --------------------- - package body Generic_Sorting is + package body Generic_Sorting with SPARK_Mode => Off is --------------- -- Is_Sorted -- diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 284f034e1ad..622454e6ee1 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -203,7 +203,7 @@ is 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; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 3e13126a481..b0bf000b936 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -9140,6 +9140,8 @@ package body Exp_Ch9 is -- 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)) @@ -9162,6 +9164,34 @@ package body Exp_Ch9 is & " 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; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 1df23b5bb08..36befa6b599 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -194,11 +194,15 @@ extern Boolean No_Strict_Aliasing_CP; #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); diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 8768e3e77de..5857094ff2b 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -302,6 +302,20 @@ package body GNAT.Debug_Pools is -- 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); @@ -460,6 +474,18 @@ package body GNAT.Debug_Pools is 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 -- -------------- @@ -481,7 +507,8 @@ package body GNAT.Debug_Pools is 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; @@ -964,12 +991,16 @@ package body GNAT.Debug_Pools is 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); @@ -1151,13 +1182,15 @@ package body GNAT.Debug_Pools is 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 @@ -1343,6 +1376,21 @@ package body GNAT.Debug_Pools is 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 -- ---------------- @@ -1411,12 +1459,11 @@ package body GNAT.Debug_Pools is 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 @@ -1439,16 +1486,20 @@ package body GNAT.Debug_Pools is 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 @@ -1594,14 +1645,10 @@ package body GNAT.Debug_Pools is (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; @@ -1787,10 +1834,12 @@ package body GNAT.Debug_Pools is 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; @@ -2090,16 +2139,16 @@ package body GNAT.Debug_Pools is 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; @@ -2180,30 +2229,34 @@ package body GNAT.Debug_Pools is 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' ... + -- 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' ... - 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; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 1db30099317..e905a0b7335 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1902,7 +1902,8 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, 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); @@ -1939,7 +1940,7 @@ __gnat_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 @@ -2039,7 +2040,7 @@ __gnat_install_handler (void) 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 (); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 8c0f90260d1..1dbd3d551ad 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -285,6 +285,24 @@ package body Restrict is 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 -- ----------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index ac0a09e0bbc..48a531d0350 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -337,6 +337,15 @@ package Restrict is -- 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 diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 75373874e27..4fdb6aca420 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -119,6 +119,8 @@ package System.Rident is 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)) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2f5b8ca9581..7ff465a805b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9883,6 +9883,8 @@ package body Sem_Res is 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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cc17f016df8..b2f1f103a1e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11125,6 +11125,17 @@ package body Sem_Util is 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 -- ---------------------------------------------- @@ -11132,20 +11143,6 @@ package body Sem_Util is 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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e882f168936..872bdedf388 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1262,6 +1262,9 @@ package Sem_Util is 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 -- 2.30.2