+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
(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;
-- 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);
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;
-- 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
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;
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;
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;
-- 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,
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
-- 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 --
----------------------------
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
-- Here to freeze the entity
- Result := No_List;
Set_Is_Frozen (E);
-- Case of entity being frozen is other than a type
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;
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
-- 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)
* *
* 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. *
}
recurse = 0;
- Raise_From_Signal_Handler (exception, (const char *) msg);
+ Raise_From_Signal_Handler (exception, (char *) msg);
}
void
/* 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);
}
/* 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);
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;
asm ("mtspr 512, %0\n\tisync" : : "r" (spefscr));
}
#else
- /* all except VxWorks 653 and MILS */
asm ("mtfsb0 25");
asm ("mtfsb0 26");
#endif
#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
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,
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,
-- 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. --
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 --
-----------------------
-- '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 --
----------------
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));
-- 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. --
-- 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.
-- 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
-- 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. --
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.
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.
-- 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);
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);
-- 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.
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
OSDN Git Service
