Skip to content

R
riscv-gcc-1
Commit 90878b12 by Arnaud Charlet
Options

[multiple changes] 

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_N_Assignment_Statement): under restriction
	No_Dispatching_Calls, do not look for the Assign primitive, because
	predefined primitives are not created in this case.

2011-08-02  Bob Duff  <duff@adacore.com>

	* stylesw.ads: Minor comment fixes.

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Add_To_Result): New procedure.

2011-08-02  Jose Ruiz  <ruiz@adacore.com>

	* exp_attr.adb (Find_Stream_Subprogram): When using a configurable run
	time, if the specific run-time routines for handling streams of strings
	are not available, use the default mechanism.

2011-08-02  Arnaud Charlet  <charlet@adacore.com>

	* s-regpat.ads: Fix typo.

2011-08-02  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Get_Or_Create_Configuration_File): If On_Load_Config is
	not null, call it to create the in memory config project file without
	parsing an existing default config project file.

2011-08-02  Eric Botcazou  <ebotcazou@adacore.com>

	* atree.adb (Allocate_Initialize_Node): Remove useless temporaries.

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_elim.adb: an abstract subprogram does not need an eliminate
	pragma for its descendant to be eliminable.

2011-08-02  Ed Falis  <falis@adacore.com>

	* init.c: revert to handling before previous checkin for VxWorks
	* s-intman-vxworks.adb: delete unnecessary declarations related to
	using Ada interrupt facilities for handling signals.
	Delete Initialize_Interrupts. Use __gnat_install_handler instead.
	* s-intman-vxworks.ads: Import __gnat_install_handler as
	Initialize_Interrupts.
	* s-taprop-vxworks.adb: Delete Signal_Mask.
	(Abort_Handler): change construction of mask to unblock exception
	signals.

From-SVN: r177130
parent 273adcdf
Showing with 311 additions and 191 deletions
gcc/ada/ChangeLog
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): under restriction
No_Dispatching_Calls, do not look for the Assign primitive, because
predefined primitives are not created in this case.
2011-08-02 Bob Duff <duff@adacore.com>
* stylesw.ads: Minor comment fixes.
2011-08-02 Robert Dewar <dewar@adacore.com>
* freeze.adb (Add_To_Result): New procedure.
2011-08-02 Jose Ruiz <ruiz@adacore.com>
* exp_attr.adb (Find_Stream_Subprogram): When using a configurable run
time, if the specific run-time routines for handling streams of strings
are not available, use the default mechanism.
2011-08-02 Arnaud Charlet <charlet@adacore.com>
* s-regpat.ads: Fix typo.
2011-08-02 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Get_Or_Create_Configuration_File): If On_Load_Config is
not null, call it to create the in memory config project file without
parsing an existing default config project file.
2011-08-02 Eric Botcazou <ebotcazou@adacore.com>
* atree.adb (Allocate_Initialize_Node): Remove useless temporaries.
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_elim.adb: an abstract subprogram does not need an eliminate
pragma for its descendant to be eliminable.
2011-08-02 Ed Falis <falis@adacore.com>
* init.c: revert to handling before previous checkin for VxWorks
* s-intman-vxworks.adb: delete unnecessary declarations related to
using Ada interrupt facilities for handling signals.
Delete Initialize_Interrupts. Use __gnat_install_handler instead.
* s-intman-vxworks.ads: Import __gnat_install_handler as
Initialize_Interrupts.
* s-taprop-vxworks.adb: Delete Signal_Mask.
(Abort_Handler): change construction of mask to unblock exception
signals.
2011-08-02 Jerome Guitton <guitton@adacore.com>
* a-except-2005.adb (Raise_From_Signal_Handler): Call
......
gcc/ada/atree.adb
......@@ -481,34 +481,25 @@ package body Atree is
(Src : Node_Id;
With_Extension : Boolean) return Node_Id
is
New_Id : Node_Id := Src;
Nod : Node_Record := Default_Node;
Ext1 : Node_Record := Default_Node_Extension;
Ext2 : Node_Record := Default_Node_Extension;
Ext3 : Node_Record := Default_Node_Extension;
Ext4 : Node_Record := Default_Node_Extension;
New_Id : Node_Id;
begin
if Present (Src) then
Nod := Nodes.Table (Src);
if Has_Extension (Src) then
Ext1 := Nodes.Table (Src + 1);
Ext2 := Nodes.Table (Src + 2);
Ext3 := Nodes.Table (Src + 3);
Ext4 := Nodes.Table (Src + 4);
end if;
end if;
if not (Present (Src)
and then not Has_Extension (Src)
and then With_Extension
and then Src = Nodes.Last)
if Present (Src)
and then not Has_Extension (Src)
and then With_Extension
and then Src = Nodes.Last
then
New_Id := Src;
else
-- We are allocating a new node, or extending a node
-- other than Nodes.Last.
Nodes.Append (Nod);
if Present (Src) then
Nodes.Append (Nodes.Table (Src));
else
Nodes.Append (Default_Node);
end if;
New_Id := Nodes.Last;
Orig_Nodes.Append (New_Id);
Node_Count := Node_Count + 1;
......@@ -524,10 +515,15 @@ package body Atree is
-- Set extension nodes if required
if With_Extension then
Nodes.Append (Ext1);
Nodes.Append (Ext2);
Nodes.Append (Ext3);
Nodes.Append (Ext4);
if Present (Src) and then Has_Extension (Src) then
for J in 1 .. 4 loop
Nodes.Append (Nodes.Table (Src + Node_Id (J)));
end loop;
else
for J in 1 .. 4 loop
Nodes.Append (Default_Node_Extension);
end loop;
end if;
end if;
Orig_Nodes.Set_Last (Nodes.Last);
......
gcc/ada/exp_attr.adb
......@@ -5517,6 +5517,21 @@ package body Exp_Attr is
Base_Typ : constant Entity_Id := Base_Type (Typ);
Ent : constant Entity_Id := TSS (Typ, Nam);
function Is_Available (Entity : RE_Id) return Boolean;
pragma Inline (Is_Available);
-- Function to check whether the specified run-time call is available
-- in the run time used. In the case of a configurable run time, it
-- is normal that some subprograms are not there.
function Is_Available (Entity : RE_Id) return Boolean is
begin
-- Assume that the unit will always be available when using a
-- "normal" (not configurable) run time.
return not Configurable_Run_Time_Mode
or else RTE_Available (Entity);
end Is_Available;
begin
if Present (Ent) then
return Ent;
......@@ -5535,6 +5550,12 @@ package body Exp_Attr is
-- This is disabled for AAMP, to avoid creating dependences on files not
-- supported in the AAMP library (such as s-fileio.adb).
-- In the case of using a configurable run time, it is very likely
-- that stream routines for string types are not present (they require
-- file system support). In this case, the specific stream routines for
-- strings are not used, relying on the regular stream mechanism
-- instead.
if VM_Target /= JVM_Target
and then not AAMP_On_Target
and then
......@@ -5544,31 +5565,61 @@ package body Exp_Attr is
if Base_Typ = Standard_String then
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_String_Input)
then
return RTE (RE_String_Input);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_String_Output)
then
return RTE (RE_String_Output);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_String_Read)
then
return RTE (RE_String_Read);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_String_Write)
then
return RTE (RE_String_Write);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
else
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_String_Input_Blk_IO)
then
return RTE (RE_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_String_Output_Blk_IO)
then
return RTE (RE_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_String_Read_Blk_IO)
then
return RTE (RE_String_Read_Blk_IO);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_String_Write_Blk_IO)
then
return RTE (RE_String_Write_Blk_IO);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
end if;
......@@ -5576,31 +5627,61 @@ package body Exp_Attr is
elsif Base_Typ = Standard_Wide_String then
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_Wide_String_Input)
then
return RTE (RE_Wide_String_Input);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_Wide_String_Output)
then
return RTE (RE_Wide_String_Output);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_Wide_String_Read)
then
return RTE (RE_Wide_String_Read);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_Wide_String_Write)
then
return RTE (RE_Wide_String_Write);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
else
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_String_Read_Blk_IO);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_String_Write_Blk_IO);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
end if;
......@@ -5608,31 +5689,61 @@ package body Exp_Attr is
elsif Base_Typ = Standard_Wide_Wide_String then
if Restriction_Active (No_Stream_Optimizations) then
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_Wide_Wide_String_Input)
then
return RTE (RE_Wide_Wide_String_Input);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_Wide_Wide_String_Output)
then
return RTE (RE_Wide_Wide_String_Output);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_Wide_Wide_String_Read)
then
return RTE (RE_Wide_Wide_String_Read);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_Wide_Wide_String_Write)
then
return RTE (RE_Wide_Wide_String_Write);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
else
if Nam = TSS_Stream_Input then
if Nam = TSS_Stream_Input
and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Input_Blk_IO);
elsif Nam = TSS_Stream_Output then
elsif Nam = TSS_Stream_Output
and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Output_Blk_IO);
elsif Nam = TSS_Stream_Read then
elsif Nam = TSS_Stream_Read
and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Read_Blk_IO);
else pragma Assert (Nam = TSS_Stream_Write);
elsif Nam = TSS_Stream_Write
and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
then
return RTE (RE_Wide_Wide_String_Write_Blk_IO);
elsif Nam /= TSS_Stream_Input and then
Nam /= TSS_Stream_Output and then
Nam /= TSS_Stream_Read and then
Nam /= TSS_Stream_Write
then
raise Program_Error;
end if;
end if;
end if;
......
gcc/ada/exp_ch5.adb
......@@ -1943,13 +1943,17 @@ package body Exp_Ch5 is
-- correspond to initializations, where we do want to copy the
-- tag (No_Ctrl_Actions flag set True) by the expander and we
-- do not need to mess with tags ever (Expand_Ctrl_Actions flag
-- is set True in this case).
-- is set True in this case). Finally, it is suppressed if the
-- restriction No_Dispatching_Calls is in force because in that
-- case predefined primitives are not generated.
or else (Is_Tagged_Type (Typ)
and then not Is_Value_Type (Etype (Lhs))
and then Chars (Current_Scope) /= Name_uAssign
and then Expand_Ctrl_Actions
and then not Discriminant_Checks_Suppressed (Empty))
and then not Discriminant_Checks_Suppressed (Empty)
and then
not Restriction_Active (No_Dispatching_Calls))
then
-- Fetch the primitive op _assign and proper type to call it.
-- Because of possible conflicts between private and full view,
......
gcc/ada/freeze.adb
......@@ -1502,14 +1502,19 @@ package body Freeze is
Test_E : Entity_Id := E;
Comp : Entity_Id;
F_Node : Node_Id;
Result : List_Id;
Indx : Node_Id;
Formal : Entity_Id;
Atype : Entity_Id;
Result : List_Id := No_List;
-- List of freezing actions, left at No_List if none
Has_Default_Initialization : Boolean := False;
-- This flag gets set to true for a variable with default initialization
procedure Add_To_Result (N : Node_Id);
-- N is a freezing action to be appended to the Result
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
......@@ -1528,6 +1533,19 @@ package body Freeze is
-- Freeze each component, handle some representation clauses, and freeze
-- primitive operations if this is a tagged type.
-------------------
-- Add_To_Result --
-------------------
procedure Add_To_Result (N : Node_Id) is
begin
if No (Result) then
Result := New_List (N);
else
Append (N, Result);
end if;
end Add_To_Result;
----------------------------
-- After_Last_Declaration --
----------------------------
......@@ -1769,12 +1787,7 @@ package body Freeze is
then
IR := Make_Itype_Reference (Sloc (Comp));
Set_Itype (IR, Desig);
if No (Result) then
Result := New_List (IR);
else
Append (IR, Result);
end if;
Add_To_Result (IR);
end if;
elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
......@@ -2421,7 +2434,6 @@ package body Freeze is
-- Here to freeze the entity
Result := No_List;
Set_Is_Frozen (E);
-- Case of entity being frozen is other than a type
......@@ -3602,11 +3614,7 @@ package body Freeze is
begin
Set_Itype (Ref, E);
if No (Result) then
Result := New_List (Ref);
else
Append (Ref, Result);
end if;
Add_To_Result (Ref);
end;
end if;
......@@ -4052,12 +4060,7 @@ package body Freeze is
end if;
Set_Entity (F_Node, E);
if Result = No_List then
Result := New_List (F_Node);
else
Append (F_Node, Result);
end if;
Add_To_Result (F_Node);
-- A final pass over record types with discriminants. If the type
-- has an incomplete declaration, there may be constrained access
......@@ -4135,6 +4138,8 @@ package body Freeze is
-- subprogram in main unit, generate descriptor if we are in
-- Propagate_Exceptions mode.
-- This is very odd code, it makes a null result, why ???
elsif Propagate_Exceptions
and then Is_Imported (E)
and then not Is_Intrinsic_Subprogram (E)
......
gcc/ada/init.c
......@@ -10,19 +10,20 @@
* *
* 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- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception under Section 7 of GPL version 3, you are granted *
* additional permissions described in the GCC Runtime Library Exception, *
* version 3.1, as published by the Free Software Foundation. *
* *
* You should have received a copy of the GNU General Public License and *
* a copy of the GCC Runtime Library Exception along with this program; *
* see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
* <http://www.gnu.org/licenses/>. *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
......@@ -378,7 +379,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
}
recurse = 0;
Raise_From_Signal_Handler (exception, (const char *) msg);
Raise_From_Signal_Handler (exception, (char *) msg);
}
void
......@@ -1975,23 +1976,20 @@ __gnat_map_signal (int sig)
/* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception
propagation after the required low level adjustments. */
sigset_t __gnat_signal_mask;
/* VxWorks will always mask out the signal during the signal handler and
will reenable it on a longjmp. GNAT does not generate a longjmp to
return from a signal handler so exception signals will still be masked
unless we unmask it. __gnat_signal mask tells sigaction to block the
exception signals and sigprocmask to unblock them. */
void
__gnat_error_handler (int sig,
void *si ATTRIBUTE_UNUSED,
struct sigcontext *sc ATTRIBUTE_UNUSED)
{
sigset_t mask;
/* This routine handles the exception signals for all tasks */
sigprocmask (SIG_UNBLOCK, &__gnat_signal_mask, NULL);
/* VxWorks will always mask out the signal during the signal handler and
will reenable it on a longjmp. GNAT does not generate a longjmp to
return from a signal handler so the signal will still be masked unless
we unmask it. */
sigprocmask (SIG_SETMASK, NULL, &mask);
sigdelset (&mask, sig);
sigprocmask (SIG_SETMASK, &mask, NULL);
__gnat_map_signal (sig);
}
......@@ -2003,24 +2001,14 @@ __gnat_install_handler (void)
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
signal that might cause a scheduling event! This routine is called
only once, for the environment task. Other tasks are set up in the
System.Interrupt_Manager package. */
sigemptyset (&__gnat_signal_mask);
sigaddset (SIGBUS, &__gnat_signal_mask);
sigaddset (SIGFPE, &__gnat_signal_mask);
sigaddset (SIGILL, &__gnat_signal_mask);
sigaddset (SIGSEGV, &__gnat_signal_mask);
signal that might cause a scheduling event! */
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_SIGINFO | SA_ONSTACK;
act.sa_mask = __gnat_signal_mask;
/* For VxWorks, unconditionally install the exception signal handlers, since
pragma Interrupt_State applies to vectored hardware interrupts, not
signals. */
sigemptyset (&act.sa_mask);
/* For VxWorks, install all signal handlers, since pragma Interrupt_State
applies to vectored hardware interrupts, not signals. */
sigaction (SIGFPE, &act, NULL);
sigaction (SIGILL, &act, NULL);
sigaction (SIGSEGV, &act, NULL);
......@@ -2040,7 +2028,6 @@ __gnat_init_float (void)
below have no effect. */
#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
#if defined (__SPE__)
/* VxWorks 6 */
{
const unsigned long spefscr_mask = 0xfffffff3;
unsigned long spefscr;
......@@ -2049,7 +2036,6 @@ __gnat_init_float (void)
asm ("mtspr 512, %0\n\tisync" : : "r" (spefscr));
}
#else
/* all except VxWorks 653 and MILS */
asm ("mtfsb0 25");
asm ("mtfsb0 26");
#endif
......@@ -2057,7 +2043,7 @@ __gnat_init_float (void)
#if (defined (__i386__) || defined (i386)) && !defined (VTHREADS)
/* This is used to properly initialize the FPU on an x86 for each
process thread. For all except VxWorks 653 */
process thread. */
asm ("finit");
#endif
......
gcc/ada/prj-conf.adb
......@@ -1107,7 +1107,12 @@ package body Prj.Conf is
Write_Line (Config_File_Path.all);
end if;
if Config_File_Path /= null then
if On_Load_Config /= null then
On_Load_Config
(Config_File => Config_Project_Node,
Project_Node_Tree => Project_Node_Tree);
elsif Config_File_Path /= null then
Prj.Part.Parse
(In_Tree => Project_Node_Tree,
Project => Config_Project_Node,
......@@ -1119,16 +1124,9 @@ package body Prj.Conf is
Flags => Flags,
Target_Name => Target_Name);
else
-- Maybe the user will want to create his own configuration file
Config_Project_Node := Empty_Node;
end if;
if On_Load_Config /= null then
On_Load_Config
(Config_File => Config_Project_Node,
Project_Node_Tree => Project_Node_Tree);
end if;
if Config_Project_Node /= Empty_Node then
Prj.Proc.Process_Project_Tree_Phase_1
(In_Tree => Project_Tree,
......
gcc/ada/s-intman-vxworks.adb
......@@ -19,10 +19,10 @@
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- In particular, you can freely distribute your programs built with the --
-- GNAT Pro compiler, including any required library run-time units, using --
-- any licensing terms of your choosing. See the AdaCore Software License --
-- for full details. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
......@@ -39,27 +39,6 @@ package body System.Interrupt_Management is
use System.OS_Interface;
use type Interfaces.C.int;
type Signal_List is array (Signal_ID range <>) of Signal_ID;
Exception_Signals : constant Signal_List (1 .. 4) :=
(SIGFPE, SIGILL, SIGSEGV, SIGBUS);
Exception_Action : aliased struct_sigaction;
-- Keep this a variable global so that it is initialized only once
Signal_Mask : aliased sigset_t;
pragma Import (C, Signal_Mask, "__gnat_signal_mask");
-- Mask indicating that all exception signals are to be masked
-- when a signal is propagated.
procedure Notify_Exception
(signo : Signal;
siginfo : System.Address;
sigcontext : System.Address);
pragma Import (C, Notify_Exception, "__gnat_error_handler");
-- Map a signal to Ada exception and raise it. Different versions
-- of VxWorks need different mappings. This is addressed in init.c in
-- __gnat_map_signal.
-----------------------
-- Local Subprograms --
-----------------------
......@@ -77,26 +56,6 @@ package body System.Interrupt_Management is
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Since there is no signal inheritance between VxWorks tasks, we need
-- to initialize signal handling in each task.
procedure Initialize_Interrupts is
Result : int;
old_act : aliased struct_sigaction;
begin
for J in Exception_Signals'Range loop
Result :=
sigaction
(Signal (Exception_Signals (J)), Exception_Action'Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end loop;
end Initialize_Interrupts;
----------------
-- Initialize --
----------------
......@@ -118,12 +77,6 @@ package body System.Interrupt_Management is
Abort_Task_Interrupt := SIGABRT;
-- Signal_Mask was initialized in __gnat_install_handler
Exception_Action.sa_handler := Notify_Exception'Address;
Exception_Action.sa_flags := SA_ONSTACK + SA_SIGINFO;
Exception_Action.sa_mask := Signal_Mask;
-- Initialize hardware interrupt handling
pragma Assert (Reserve = (Interrupt_ID'Range => False));
......
gcc/ada/s-intman-vxworks.ads
......@@ -19,10 +19,10 @@
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- In particular, you can freely distribute your programs built with the --
-- GNAT Pro compiler, including any required library run-time units, using --
-- any licensing terms of your choosing. See the AdaCore Software License --
-- for full details. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
......@@ -87,6 +87,7 @@ package System.Interrupt_Management is
-- or used to implement time delays.
procedure Initialize_Interrupts;
pragma Import (C, Initialize_Interrupts, "__gnat_install_handler");
-- Under VxWorks, there is no signal inheritance between tasks.
-- This procedure is used to initialize signal-to-exception mapping in
-- each task.
......
gcc/ada/s-regpat.ads
......@@ -349,7 +349,7 @@ package System.Regpat is
-- 12 3
-- Matches (0) is for "a((b*)c+)(d+)" (the entire expression)
-- Matches (1) is for "(b*)c+"
-- Matches (2) is for "c+"
-- Matches (2) is for "b*"
-- Matches (3) is for "d+"
--
-- The number of parenthesis groups that can be retrieved is limited only
......
gcc/ada/s-taprop-vxworks.adb
......@@ -19,10 +19,10 @@
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- In particular, you can freely distribute your programs built with the --
-- GNAT Pro compiler, including any required library run-time units, using --
-- any licensing terms of your choosing. See the AdaCore Software License --
-- for full details. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
......@@ -94,11 +94,6 @@ package body System.Task_Primitives.Operations is
Mutex_Protocol : Priority_Type;
Signal_Mask : aliased sigset_t;
pragma Import (C, Signal_Mask, "__gnat_signal_mask");
-- Mask indicating that all exception signals are to be masked
-- when a signal is propagated.
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at a
-- time; it is used to execute in mutual exclusion from all other tasks.
......@@ -180,11 +175,14 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (signo : Signal) is
pragma Unreferenced (signo);
Self_ID : constant Task_Id := Self;
Old_Set : aliased sigset_t;
Result : int;
Self_ID : constant Task_Id := Self;
Old_Set : aliased sigset_t;
Unblocked_Mask : aliased sigset_t;
Result : int;
pragma Warnings (Off, Result);
use System.Interrupt_Management;
begin
-- It is not safe to raise an exception when using ZCX and the GCC
-- exception handling mechanism.
......@@ -201,10 +199,26 @@ package body System.Task_Primitives.Operations is
-- Make sure signals used for RTS internal purposes are unmasked
Result := sigemptyset (Unblocked_Mask'Access);
pragma Assert (Result = 0);
Result :=
sigaddset
(Unblocked_Mask'Access,
Signal (Abort_Task_Interrupt));
pragma Assert (Result = 0);
Result := sigaddset (Unblocked_Mask'Access, SIGBUS);
pragma Assert (Result = 0);
Result := sigaddset (Unblocked_Mask'Access, SIGFPE);
pragma Assert (Result = 0);
Result := sigaddset (Unblocked_Mask'Access, SIGILL);
pragma Assert (Result = 0);
Result := sigaddset (Unblocked_Mask'Access, SIGSEGV);
pragma Assert (Result = 0);
Result :=
pthread_sigmask
(SIG_UNBLOCK,
Signal_Mask'Access,
Unblocked_Mask'Access,
Old_Set'Access);
pragma Assert (Result = 0);
......
gcc/ada/sem_elim.adb
......@@ -282,6 +282,7 @@ package body Sem_Elim is
if Present (Overridden)
and then not Is_Eliminated (Overridden)
and then not Is_Abstract_Subprogram (Overridden)
then
Error_Msg_Name_1 := Chars (E);
Error_Msg_N ("cannot eliminate subprogram %", E);
......
gcc/ada/stylesw.ads
......@@ -40,10 +40,10 @@ package Stylesw is
-- options. The default values shown here correspond to no style checking.
-- If any of these values is set to a non-default value, then
-- Opt.Style_Check is set True to active calls to this package.
-- Opt.Style_Check is set True to activate calls to this package.
-- The actual mechanism for setting these switches to other than default
-- values is via the Set_Style_Check_Option procedure or through a call to
-- values is via the Set_Style_Check_Options procedure or through a call to
-- Set_Default_Style_Check_Options. They should not be set directly in any
-- other manner.
......@@ -315,8 +315,8 @@ package Stylesw is
procedure Set_Style_Check_Options (Options : String);
-- Like the above procedure, but used when the Options string is known to
-- be valid. This is for example appropriate for calls where the string ==
-- was obtained by Save_Style_Check_Options.
-- be valid. This is for example appropriate for calls where the string was
-- obtained by Save_Style_Check_Options.
procedure Reset_Style_Check_Options;
-- Sets all style check options to off
......
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