Skip to content

R
riscv-gcc-1
Commit 81408d49 by Doug Rupp Committed by Arnaud Charlet
Options

mlib-tgt-vms-ia64.adb, [...] (Is_Interface): Change Ada bind file prefix on VMS from b$ to b__. 

2005-12-05  Doug Rupp  <rupp@adacore.com>

	* mlib-tgt-vms-ia64.adb, mlib-tgt-vms-alpha.adb (Is_Interface): Change
	Ada bind file prefix on VMS from b$ to b__.
	(Build_Dynamic_Library): Change Init file suffix on VMS from $init to
	__init.

	* prj-nmsc.adb: Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.
	(Object_Suffix): Initialize with target object suffix.
	(Get_Unit): Change Ada bind file prefix on VMS from b$ to b__.

	* butil.adb: Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.

	* clean.adb: Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.
	(Object_Suffix): Initialize with call to Get_Target_Object_Suffix.
	({declaraction},Delete_Binder_Generated_Files,{initialization}): Change
	Ada bind file prefix on VMS from b$ to b__.

	* gnatlink.adb (Process_Args): Call Add_Src_Search_Dir for -I in
	--GCC so that Get_Target_Parameters can find system.ads.
	(Gnatlink): Call Get_Target_Parameters in mainline.
	Initialize standard packages for Targparm.
	Change some Hostparm.OpenVMS checks to Targparm.OpenVMS_On_Target.
	(Process_Args): Also Check for object files with target object
	extension.
	(Make_Binder_File_Names): Create with target object extension.
	(Make_Binder_File_Names): Change Ada bind file prefix on VMS from b$
	to b__.

	* mlib-prj.adb: Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.
	({declaration},Build_Library,Check_Library): Change Ada bind file
	prefix on VMS from b$ to b__.

	* osint-b.adb: Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.
	(Create_Binder_Output): Change Ada bind file prefix on VMS from b$ to
	b__.

	* targext.c: New file.

	* Makefile.in: add support for vxworks653 builds
	(../../vxaddr2line): gnatlink with targext.o.
	(TOOLS_LIBS): Move targext.o to precede libgnat.
	(init.o, initialize.o): Minor clean up in dependencies.
	(GNATLINK_OBJS): Add targparm.o, snames.o
	Add rules fo building targext.o and linking it explicitly with all
	tools.
	Also add targext.o to gnatlib.

	* Make-lang.in: Add rules for building targext.o and linking it in
	with gnat1 and gnatbind.
	Add entry for exp_sel.o.

	* osint.adb Change some Hostparm.OpenVMS checks to
	Targparm.OpenVMS_On_Target.
	(Object_File_Name): Use target object suffix.

	* osint.ads (Object_Suffix): Remove, no longer used.
	(Target_Object_Suffix): Initialize with target object suffix.

	* rident.ads: Add special exception to license.

	* targparm.adb (Get_Target_Parameters): Set the value of
	Multi_Unit_Index_Character after OpenVMS_On_Target gets its definitive
	value.
	(Get_Target_Parameters): Set OpenVMS_On_Target if openvms.
	
	* targparm.ads: Add special exception to license.

	* g-os_lib.ads, g-os_lib.adb (Get_Target_Debuggable_Suffix): New
	function.
	(Copy_File): Make sure from file is closed if error on to file
	(Get_Target_Executable_Suffix, Get_Target_Object_Suffix): New functions.

	* make.adb (Object_Suffix): Intialize with Get_Target_Object_Suffix.
	(Executable_Suffix): Intialize with Get_Target_Executable_Suffix.

	* osint-c.adb (Set_Output_Object_File_Name): Initialize extension with
	target object suffix.

From-SVN: r108282
parent 9d0aa6ab
Showing with 976 additions and 61 deletions
gcc/ada/Makefile.rtl
# Makefile.rtl for GNU Ada Compiler (GNAT). # Makefile.rtl for GNU Ada Compiler (GNAT).
# Copyright (C) 2003, 2004 Free Software Foundation, Inc. # Copyright (C) 2003-2005, Free Software Foundation, Inc.
#This file is part of GCC. #This file is part of GCC.
...@@ -35,6 +35,7 @@ GNATRTL_TASKING_OBJS= \ ...@@ -35,6 +35,7 @@ GNATRTL_TASKING_OBJS= \
a-sytaco$(objext) \ a-sytaco$(objext) \
a-tasatt$(objext) \ a-tasatt$(objext) \
a-taside$(objext) \ a-taside$(objext) \
a-taster$(objext) \
g-boubuf$(objext) \ g-boubuf$(objext) \
g-boumai$(objext) \ g-boumai$(objext) \
g-semaph$(objext) \ g-semaph$(objext) \
...@@ -279,6 +280,13 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -279,6 +280,13 @@ GNATRTL_NONTASKING_OBJS= \
a-zzunio$(objext) \ a-zzunio$(objext) \
ada$(objext) \ ada$(objext) \
calendar$(objext) \ calendar$(objext) \
g-allein$(objext) \
g-alleve$(objext) \
g-altcon$(objext) \
g-altive$(objext) \
g-alveop$(objext) \
g-alvety$(objext) \
g-alvevi$(objext) \
g-arrspl$(objext) \ g-arrspl$(objext) \
g-awk$(objext) \ g-awk$(objext) \
g-bubsor$(objext) \ g-bubsor$(objext) \
...@@ -497,6 +505,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -497,6 +505,7 @@ GNATRTL_NONTASKING_OBJS= \
s-sopco4$(objext) \ s-sopco4$(objext) \
s-sopco5$(objext) \ s-sopco5$(objext) \
s-stache$(objext) \ s-stache$(objext) \
s-stausa$(objext) \
s-stchop$(objext) \ s-stchop$(objext) \
s-stalib$(objext) \ s-stalib$(objext) \
s-stoele$(objext) \ s-stoele$(objext) \
......
gcc/ada/a-elchha.adb
...@@ -38,6 +38,11 @@ ...@@ -38,6 +38,11 @@
-- Default version for most targets -- Default version for most targets
with System.Standard_Library; use System.Standard_Library; with System.Standard_Library; use System.Standard_Library;
-- Used for Adafinal
with System.Soft_Links;
-- Used for Task_Termination_Handler
-- Task_Termination_NT
procedure Ada.Exceptions.Last_Chance_Handler procedure Ada.Exceptions.Last_Chance_Handler
(Except : Exception_Occurrence) (Except : Exception_Occurrence)
...@@ -72,6 +77,14 @@ is ...@@ -72,6 +77,14 @@ is
-- Convenient shortcut -- Convenient shortcut
begin begin
-- Do not execute any task termination code when shutting down the system.
-- The Adafinal procedure would execute the task termination routine for
-- normal termination, but we have already executed the task termination
-- procedure because of an unhandled exception.
System.Soft_Links.Task_Termination_Handler :=
System.Soft_Links.Task_Termination_NT'Access;
-- Let's shutdown the runtime now. The rest of the procedure needs to be -- Let's shutdown the runtime now. The rest of the procedure needs to be
-- careful not to use anything that would require runtime support. In -- careful not to use anything that would require runtime support. In
-- particular, functions returning strings are banned since the sec stack -- particular, functions returning strings are banned since the sec stack
......
gcc/ada/a-exextr.adb
...@@ -88,7 +88,7 @@ package body Exception_Traces is ...@@ -88,7 +88,7 @@ package body Exception_Traces is
-- Hook for GDB to support "break exception unhandled" -- Hook for GDB to support "break exception unhandled"
-- For "break exception", GDB uses __gnat_raise_nodefer_with_msg, which -- For "break exception", GDB uses __gnat_raise_nodefer_with_msg, which
-- is not in this section because it fullfills other purposes than a mere -- is not in this section because it functions as more than simply a
-- debugger interface. -- debugger interface.
-------------------------------- --------------------------------
...@@ -161,8 +161,18 @@ package body Exception_Traces is ...@@ -161,8 +161,18 @@ package body Exception_Traces is
-------------------------------- --------------------------------
procedure Notify_Unhandled_Exception is procedure Notify_Unhandled_Exception is
Excep : constant EOA := Get_Current_Excep.all;
begin begin
Notify_Exception (Get_Current_Excep.all, Is_Unhandled => True); -- Check whether there is any termination handler to be executed for
-- the environment task, and execute it if needed. Here we handle both
-- the Abnormal and Unhandled_Exception task termination. Normal
-- task termination routine is executed elsewhere (either in the
-- Task_Wrapper or in the Adafinal routine for the environment task).
Task_Termination_Handler.all (Excep.all);
Notify_Exception (Excep, Is_Unhandled => True);
Unhandled_Exception; Unhandled_Exception;
end Notify_Unhandled_Exception; end Notify_Unhandled_Exception;
......
gcc/ada/a-taside.adb
...@@ -44,7 +44,8 @@ pragma Warnings (Off); ...@@ -44,7 +44,8 @@ pragma Warnings (Off);
-- package will be categorized as Preelaborate. See AI-362 for details. -- package will be categorized as Preelaborate. See AI-362 for details.
-- It is safe in the context of the run-time to violate the rules! -- It is safe in the context of the run-time to violate the rules!
with System.Tasking.Stages; with System.Tasking.Utilities;
-- Used for Abort_Tasks
pragma Warnings (On); pragma Warnings (On);
...@@ -81,7 +82,7 @@ package body Ada.Task_Identification is ...@@ -81,7 +82,7 @@ package body Ada.Task_Identification is
if T = Null_Task_Id then if T = Null_Task_Id then
raise Program_Error; raise Program_Error;
else else
System.Tasking.Stages.Abort_Tasks System.Tasking.Utilities.Abort_Tasks
(System.Tasking.Task_List'(1 => Convert_Ids (T))); (System.Tasking.Task_List'(1 => Convert_Ids (T)));
end if; end if;
end Abort_Task; end Abort_Task;
......
gcc/ada/a-taster.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A S K _ T E R M I N A T I O N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2005, 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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 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. 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, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception 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. --
-- --
------------------------------------------------------------------------------
with System.Tasking;
-- used for Task_Id
with System.Task_Primitives.Operations;
-- used for Self
with Unchecked_Conversion;
package body Ada.Task_Termination is
use type Ada.Task_Identification.Task_Id;
package STPO renames System.Task_Primitives.Operations;
-----------------------
-- Local subprograms --
-----------------------
function To_TT is new Unchecked_Conversion
(System.Tasking.Termination_Handler, Termination_Handler);
function To_ST is new Unchecked_Conversion
(Termination_Handler, System.Tasking.Termination_Handler);
function To_Task_Id is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
-----------------------------------
-- Current_Task_Fallback_Handler --
-----------------------------------
function Current_Task_Fallback_Handler return Termination_Handler is
begin
return To_TT (System.Tasking.Self.Common.Fall_Back_Handler);
end Current_Task_Fallback_Handler;
-------------------------------------
-- Set_Dependents_Fallback_Handler --
-------------------------------------
procedure Set_Dependents_Fallback_Handler
(Handler : Termination_Handler)
is
begin
STPO.Self.Common.Fall_Back_Handler := To_ST (Handler);
end Set_Dependents_Fallback_Handler;
--------------------------
-- Set_Specific_Handler --
--------------------------
procedure Set_Specific_Handler
(T : Ada.Task_Identification.Task_Id;
Handler : Termination_Handler)
is
begin
-- Tasking_Error is raised if the task identified by T has already
-- terminated. Program_Error is raised if the value of T is
-- Null_Task_Id.
if T = Ada.Task_Identification.Null_Task_Id then
raise Program_Error;
elsif Ada.Task_Identification.Is_Terminated (T) then
raise Tasking_Error;
else
To_Task_Id (T).Common.Specific_Handler := To_ST (Handler);
end if;
end Set_Specific_Handler;
----------------------
-- Specific_Handler --
----------------------
function Specific_Handler
(T : Ada.Task_Identification.Task_Id) return Termination_Handler
is
begin
-- Tasking_Error is raised if the task identified by T has already
-- terminated. Program_Error is raised if the value of T is
-- Null_Task_Id.
if T = Ada.Task_Identification.Null_Task_Id then
raise Program_Error;
elsif Ada.Task_Identification.Is_Terminated (T) then
raise Tasking_Error;
else
return To_TT (To_Task_Id (T).Common.Specific_Handler);
end if;
end Specific_Handler;
end Ada.Task_Termination;
gcc/ada/a-taster.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T A S K _ T E R M I N A T I O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2005, 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Task_Identification;
with Ada.Exceptions;
package Ada.Task_Termination is
pragma Preelaborate (Task_Termination);
type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception);
type Termination_Handler is access protected procedure
(Cause : Cause_Of_Termination;
T : Ada.Task_Identification.Task_Id;
X : Ada.Exceptions.Exception_Occurrence);
procedure Set_Dependents_Fallback_Handler
(Handler : Termination_Handler);
function Current_Task_Fallback_Handler return Termination_Handler;
procedure Set_Specific_Handler
(T : Ada.Task_Identification.Task_Id;
Handler : Termination_Handler);
function Specific_Handler
(T : Ada.Task_Identification.Task_Id) return Termination_Handler;
end Ada.Task_Termination;
gcc/ada/bindgen.adb
...@@ -1268,6 +1268,22 @@ package body Bindgen is ...@@ -1268,6 +1268,22 @@ package body Bindgen is
WBI (" pragma Import (C, finalize, ""__gnat_finalize"");"); WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
end if; end if;
-- If we want to analyze the stack, we have to import corresponding
-- symbols
if Dynamic_Stack_Measurement then
WBI ("");
WBI (" procedure Output_Results;");
WBI (" pragma Import (C, Output_Results, " &
"""__gnat_stack_usage_output_results"");");
WBI ("");
WBI (" " &
"procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
WBI (" pragma Import (C, Initialize_Stack_Analysis, " &
"""__gnat_stack_usage_initialize"");");
end if;
-- Deal with declarations for main program case -- Deal with declarations for main program case
if not No_Main_Subprogram then if not No_Main_Subprogram then
...@@ -1360,6 +1376,13 @@ package body Bindgen is ...@@ -1360,6 +1376,13 @@ package body Bindgen is
Write_Statement_Buffer; Write_Statement_Buffer;
end if; end if;
if Dynamic_Stack_Measurement then
Set_String (" Initialize_Stack_Analysis (");
Set_Int (Dynamic_Stack_Measurement_Array_Size);
Set_String (");");
Write_Statement_Buffer;
end if;
if not Cumulative_Restrictions.Set (No_Finalization) then if not Cumulative_Restrictions.Set (No_Finalization) then
if not No_Main_Subprogram if not No_Main_Subprogram
...@@ -1398,6 +1421,12 @@ package body Bindgen is ...@@ -1398,6 +1421,12 @@ package body Bindgen is
end if; end if;
end if; end if;
-- Prints the result of static stack analysis
if Dynamic_Stack_Measurement then
WBI (" Output_Results;");
end if;
-- Finalize is only called if we have a run time -- Finalize is only called if we have a run time
if not Cumulative_Restrictions.Set (No_Finalization) then if not Cumulative_Restrictions.Set (No_Finalization) then
...@@ -1506,6 +1535,15 @@ package body Bindgen is ...@@ -1506,6 +1535,15 @@ package body Bindgen is
Write_Statement_Buffer; Write_Statement_Buffer;
end if; end if;
-- Initializes dynamic stack measurement if needed
if Dynamic_Stack_Measurement then
Set_String (" __gnat_stack_usage_initialize (");
Set_Int (Dynamic_Stack_Measurement_Array_Size);
Set_String (");");
Write_Statement_Buffer;
end if;
-- The __gnat_initialize routine is used only if we have a run-time -- The __gnat_initialize routine is used only if we have a run-time
if not Suppress_Standard_Library_On_Target then if not Suppress_Standard_Library_On_Target then
...@@ -1552,6 +1590,12 @@ package body Bindgen is ...@@ -1552,6 +1590,12 @@ package body Bindgen is
WBI (" system__standard_library__adafinal ();"); WBI (" system__standard_library__adafinal ();");
end if; end if;
-- Outputs the dynamic stack measurement if needed
if Dynamic_Stack_Measurement then
WBI (" __gnat_stack_usage_output_results ();");
end if;
-- The finalize routine is used only if we have a run-time -- The finalize routine is used only if we have a run-time
if not Suppress_Standard_Library_On_Target then if not Suppress_Standard_Library_On_Target then
...@@ -1681,7 +1725,7 @@ package body Bindgen is ...@@ -1681,7 +1725,7 @@ package body Bindgen is
-- filename object is seen. Multiply defined symbols will -- filename object is seen. Multiply defined symbols will
-- result. -- result.
if Hostparm.OpenVMS if OpenVMS_On_Target
and then Is_Internal_File_Name and then Is_Internal_File_Name
(ALIs.Table (ALIs.Table
(Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
...@@ -2244,6 +2288,12 @@ package body Bindgen is ...@@ -2244,6 +2288,12 @@ package body Bindgen is
WBI ("extern void __gnat_install_handler (void);"); WBI ("extern void __gnat_install_handler (void);");
end if; end if;
if Dynamic_Stack_Measurement then
WBI ("");
WBI ("extern void __gnat_stack_usage_output_results (void);");
WBI ("extern void __gnat_stack_usage_initialize (int size);");
end if;
WBI (""); WBI ("");
Gen_Elab_Defs_C; Gen_Elab_Defs_C;
...@@ -2780,7 +2830,7 @@ package body Bindgen is ...@@ -2780,7 +2830,7 @@ package body Bindgen is
With_GNARL := True; With_GNARL := True;
end if; end if;
if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
With_DECGNAT := True; With_DECGNAT := True;
end if; end if;
end loop; end loop;
......
gcc/ada/bindusg.adb
...@@ -214,6 +214,12 @@ begin ...@@ -214,6 +214,12 @@ begin
Write_Str (" -Tn Set time slice value to n milliseconds (n >= 0)"); Write_Str (" -Tn Set time slice value to n milliseconds (n >= 0)");
Write_Eol; Write_Eol;
-- Line for -u switch
Write_Str (" -un Enable dynamic stack analysis, with n results ");
Write_Str ("stored");
Write_Eol;
-- Line for -v switch -- Line for -v switch
Write_Str (" -v Verbose mode. Error messages, "); Write_Str (" -v Verbose mode. Error messages, ");
......
gcc/ada/g-alleve.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-altcon.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A L T I V E C . C O N V E R S I O N S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2005, 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- --
-- 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. 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, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception 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. --
-- --
------------------------------------------------------------------------------
-- This unit provides the Vector/Views conversions
with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types;
with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views;
package GNAT.Altivec.Conversions is
---------------------
-- char components --
---------------------
function To_Vector (S : VUC_View) return VUC;
function To_Vector (S : VSC_View) return VSC;
function To_Vector (S : VBC_View) return VBC;
function To_View (S : VUC) return VUC_View;
function To_View (S : VSC) return VSC_View;
function To_View (S : VBC) return VBC_View;
----------------------
-- short components --
----------------------
function To_Vector (S : VUS_View) return VUS;
function To_Vector (S : VSS_View) return VSS;
function To_Vector (S : VBS_View) return VBS;
function To_View (S : VUS) return VUS_View;
function To_View (S : VSS) return VSS_View;
function To_View (S : VBS) return VBS_View;
--------------------
-- int components --
--------------------
function To_Vector (S : VUI_View) return VUI;
function To_Vector (S : VSI_View) return VSI;
function To_Vector (S : VBI_View) return VBI;
function To_View (S : VUI) return VUI_View;
function To_View (S : VSI) return VSI_View;
function To_View (S : VBI) return VBI_View;
----------------------
-- float components --
----------------------
function To_Vector (S : VF_View) return VF;
function To_View (S : VF) return VF_View;
----------------------
-- pixel components --
----------------------
function To_Vector (S : VP_View) return VP;
function To_View (S : VP) return VP_View;
private
-- We want the above subprograms to always be inlined in the case of the
-- hard PowerPC AltiVec support in order to avoid the unnecessary function
-- call. On the other hand there is no problem with inlining these
-- subprograms on little-endian targets.
pragma Inline_Always (To_Vector);
pragma Inline_Always (To_View);
end GNAT.Altivec.Conversions;
gcc/ada/g-alveop.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-alveop.ads 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-alvety.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A L T I V E C . V E C T O R _ T Y P E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2005, 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- --
-- 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. 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, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception 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. --
-- --
------------------------------------------------------------------------------
-- This unit exposes the various vector types part of the Ada binding to
-- Altivec facilities.
with GNAT.Altivec.Low_Level_Vectors;
package GNAT.Altivec.Vector_Types is
use GNAT.Altivec.Low_Level_Vectors;
---------------------------------------------------
-- Vector type declarations [PIM-2.1 Data Types] --
---------------------------------------------------
-- Except for assignments and pointer creation/dereference, operations
-- on vectors are only performed via subprograms. The vector types are
-- then private, and non-limited since assignments are allowed.
-- The Hard/Soft binding type-structure differentiation is achieved in
-- Low_Level_Vectors. Each version only exposes private vector types, that
-- we just sub-type here. This is fine from the design standpoint and
-- reduces the amount of explicit conversion required in various places
-- internally.
subtype vector_unsigned_char is Low_Level_Vectors.LL_VUC;
subtype vector_signed_char is Low_Level_Vectors.LL_VSC;
subtype vector_bool_char is Low_Level_Vectors.LL_VBC;
subtype vector_unsigned_short is Low_Level_Vectors.LL_VUS;
subtype vector_signed_short is Low_Level_Vectors.LL_VSS;
subtype vector_bool_short is Low_Level_Vectors.LL_VBS;
subtype vector_unsigned_int is Low_Level_Vectors.LL_VUI;
subtype vector_signed_int is Low_Level_Vectors.LL_VSI;
subtype vector_bool_int is Low_Level_Vectors.LL_VBI;
subtype vector_float is Low_Level_Vectors.LL_VF;
subtype vector_pixel is Low_Level_Vectors.LL_VP;
-- [PIM-2.1] shows groups of declarations with exact same component types,
-- e.g. vector unsigned short together with vector unsigned short int. It
-- so appears tempting to define subtypes for those matches here.
--
-- [PIM-2.1] does not qualify items in those groups as "the same types",
-- though, and [PIM-2.4.2 Assignments] reads: "if either the left hand
-- side or the right hand side of an expression has a vector type, then
-- both sides of the expression must be of the same vector type".
--
-- Not so clear what is exactly right, then. We go with subtypes for now
-- and can adjust later if need be.
subtype vector_unsigned_short_int is vector_unsigned_short;
subtype vector_signed_short_int is vector_signed_short;
subtype vector_char is vector_signed_char;
subtype vector_short is vector_signed_short;
subtype vector_int is vector_signed_int;
--------------------------------
-- Corresponding access types --
--------------------------------
type vector_unsigned_char_ptr is access all vector_unsigned_char;
type vector_signed_char_ptr is access all vector_signed_char;
type vector_bool_char_ptr is access all vector_bool_char;
type vector_unsigned_short_ptr is access all vector_unsigned_short;
type vector_signed_short_ptr is access all vector_signed_short;
type vector_bool_short_ptr is access all vector_bool_short;
type vector_unsigned_int_ptr is access all vector_unsigned_int;
type vector_signed_int_ptr is access all vector_signed_int;
type vector_bool_int_ptr is access all vector_bool_int;
type vector_float_ptr is access all vector_float;
type vector_pixel_ptr is access all vector_pixel;
--------------------------------------------------------------------
-- Additional access types, for the sake of some argument passing --
--------------------------------------------------------------------
-- ... because some of the operations expect pointers to possibly
-- constant objects.
type const_vector_bool_char_ptr is access constant vector_bool_char;
type const_vector_signed_char_ptr is access constant vector_signed_char;
type const_vector_unsigned_char_ptr is access constant vector_unsigned_char;
type const_vector_bool_short_ptr is access constant vector_bool_short;
type const_vector_signed_short_ptr is access constant vector_signed_short;
type const_vector_unsigned_short_ptr is access
constant vector_unsigned_short;
type const_vector_bool_int_ptr is access constant vector_bool_int;
type const_vector_signed_int_ptr is access constant vector_signed_int;
type const_vector_unsigned_int_ptr is access constant vector_unsigned_int;
type const_vector_float_ptr is access constant vector_float;
type const_vector_pixel_ptr is access constant vector_pixel;
----------------------
-- Useful shortcuts --
----------------------
subtype VUC is vector_unsigned_char;
subtype VSC is vector_signed_char;
subtype VBC is vector_bool_char;
subtype VUS is vector_unsigned_short;
subtype VSS is vector_signed_short;
subtype VBS is vector_bool_short;
subtype VUI is vector_unsigned_int;
subtype VSI is vector_signed_int;
subtype VBI is vector_bool_int;
subtype VP is vector_pixel;
subtype VF is vector_float;
end GNAT.Altivec.Vector_Types;
gcc/ada/g-alvevi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A L T I V E C . V E C T O R _ V I E W S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2005, 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- --
-- 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. 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, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception 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. --
-- --
------------------------------------------------------------------------------
-- This unit provides public 'View' data types from/to which private vector
-- representations can be converted via Altivec.Conversions. This allows
-- convenient access to individual vector elements and provides a simple way
-- to initialize vector objects.
-- Accessing vector contents with direct memory overlays should be avoided
-- because actual vector representations may vary across configurations, for
-- instance to accomodate different target endianness.
-- The natural representation of a vector is an array indexed by vector
-- component number, which is materialized by the Varray type definitions
-- below. The 16byte alignment constraint is unfortunately sometimes not
-- properly honored for constant array aggregates, so the View types are
-- actually records enclosing such arrays.
package GNAT.Altivec.Vector_Views is
---------------------
-- char components --
---------------------
type Vchar_Range is range 1 .. 16;
type Varray_unsigned_char is array (Vchar_Range) of unsigned_char;
for Varray_unsigned_char'Alignment use VECTOR_ALIGNMENT;
type VUC_View is record
Values : Varray_unsigned_char;
end record;
type Varray_signed_char is array (Vchar_Range) of signed_char;
for Varray_signed_char'Alignment use VECTOR_ALIGNMENT;
type VSC_View is record
Values : Varray_signed_char;
end record;
type Varray_bool_char is array (Vchar_Range) of bool_char;
for Varray_bool_char'Alignment use VECTOR_ALIGNMENT;
type VBC_View is record
Values : Varray_bool_char;
end record;
----------------------
-- short components --
----------------------
type Vshort_Range is range 1 .. 8;
type Varray_unsigned_short is array (Vshort_Range) of unsigned_short;
for Varray_unsigned_short'Alignment use VECTOR_ALIGNMENT;
type VUS_View is record
Values : Varray_unsigned_short;
end record;
type Varray_signed_short is array (Vshort_Range) of signed_short;
for Varray_signed_short'Alignment use VECTOR_ALIGNMENT;
type VSS_View is record
Values : Varray_signed_short;
end record;
type Varray_bool_short is array (Vshort_Range) of bool_short;
for Varray_bool_short'Alignment use VECTOR_ALIGNMENT;
type VBS_View is record
Values : Varray_bool_short;
end record;
--------------------
-- int components --
--------------------
type Vint_Range is range 1 .. 4;
type Varray_unsigned_int is array (Vint_Range) of unsigned_int;
for Varray_unsigned_int'Alignment use VECTOR_ALIGNMENT;
type VUI_View is record
Values : Varray_unsigned_int;
end record;
type Varray_signed_int is array (Vint_Range) of signed_int;
for Varray_signed_int'Alignment use VECTOR_ALIGNMENT;
type VSI_View is record
Values : Varray_signed_int;
end record;
type Varray_bool_int is array (Vint_Range) of bool_int;
for Varray_bool_int'Alignment use VECTOR_ALIGNMENT;
type VBI_View is record
Values : Varray_bool_int;
end record;
----------------------
-- float components --
----------------------
type Vfloat_Range is range 1 .. 4;
type Varray_float is array (Vfloat_Range) of C_float;
for Varray_float'Alignment use VECTOR_ALIGNMENT;
type VF_View is record
Values : Varray_float;
end record;
----------------------
-- pixel components --
----------------------
type Vpixel_Range is range 1 .. 8;
type Varray_pixel is array (Vpixel_Range) of pixel;
for Varray_pixel'Alignment use VECTOR_ALIGNMENT;
type VP_View is record
Values : Varray_pixel;
end record;
end GNAT.Altivec.Vector_Views;
gcc/ada/impunit.adb
...@@ -195,6 +195,11 @@ package body Impunit is ...@@ -195,6 +195,11 @@ package body Impunit is
-- GNAT Library Units -- -- GNAT Library Units --
------------------------ ------------------------
"g-altive", -- GNAT.Altivec
"g-alvety", -- GNAT.Altivec.Vector_Types
"g-alvevi", -- GNAT.Altivec.Vector_Views
"g-alveop", -- GNAT.Altivec.Vector_Operations
"g-altcon", -- GNAT.Altivec.Conversions
"g-arrspl", -- GNAT.Array_Split "g-arrspl", -- GNAT.Array_Split
"g-awk ", -- GNAT.AWK "g-awk ", -- GNAT.AWK
"g-boubuf", -- GNAT.Bounded_Buffers "g-boubuf", -- GNAT.Bounded_Buffers
...@@ -359,12 +364,13 @@ package body Impunit is ...@@ -359,12 +364,13 @@ package body Impunit is
"a-stzmap", -- Ada.Strings.Wide_Wide_Maps "a-stzmap", -- Ada.Strings.Wide_Wide_Maps
"a-stzunb", -- Ada.Strings.Wide_Wide_Unbounded "a-stzunb", -- Ada.Strings.Wide_Wide_Unbounded
"a-swuwha", -- Ada.Strings.Wide_Unbounded.Wide_Hash "a-swuwha", -- Ada.Strings.Wide_Unbounded.Wide_Hash
"a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants; "a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants
"a-szuzha", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash "a-szuzha", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
"a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor; "a-taster", -- Ada.Task_Termination
"a-tiunio", -- Ada.Text_IO.Unbounded_IO; "a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor
"a-tiunio", -- Ada.Text_IO.Unbounded_IO
"a-wichun", -- Ada.Wide_Characters.Unicode "a-wichun", -- Ada.Wide_Characters.Unicode
"a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO; "a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO
"a-zchara", -- Ada.Wide_Wide_Characters "a-zchara", -- Ada.Wide_Wide_Characters
"a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams "a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams
"a-ztexio", -- Ada.Wide_Wide_Text_IO "a-ztexio", -- Ada.Wide_Wide_Text_IO
......
gcc/ada/opt.ads
...@@ -344,6 +344,17 @@ package Opt is ...@@ -344,6 +344,17 @@ package Opt is
-- Set True for dynamic elaboration checking mode, as set by the -gnatE -- Set True for dynamic elaboration checking mode, as set by the -gnatE
-- switch or by the use of pragma Elaboration_Checks (Dynamic). -- switch or by the use of pragma Elaboration_Checks (Dynamic).
Dynamic_Stack_Measurement : Boolean := False;
-- GNATBIND
-- Set True to enable dynamic stack measurement (-u flag for gnatbind)
Dynamic_Stack_Measurement_Array_Size : Nat := 100;
-- GNATBIND
-- Number of measurements we want to store during dynamic stack analysis.
-- When the buffer is full, non-storable results will be output on the fly.
-- The value is relevant only if Dynamic_Stack_Measurement is set. Set
-- by processing of -u flag for gnatbind.
Elab_Dependency_Output : Boolean := False; Elab_Dependency_Output : Boolean := False;
-- GNATBIND -- GNATBIND
-- Set to True to output complete list of elaboration constraints -- Set to True to output complete list of elaboration constraints
...@@ -687,15 +698,6 @@ package Opt is ...@@ -687,15 +698,6 @@ package Opt is
-- extension, as set by the appropriate switch. If no switch is given, -- extension, as set by the appropriate switch. If no switch is given,
-- then this value is initialized by Osint to the appropriate value. -- then this value is initialized by Osint to the appropriate value.
Max_Line_Length : Int := Hostparm.Max_Line_Length;
-- This is a copy of Max_Line_Length used by the scanner. It is usually
-- set to be a copy of Hostparm.Max_Line_Length, and is used to check
-- the maximum line length in the scanner when style checking is inactive.
-- The only time it is set to a different value is during the scanning of
-- configuration pragma files, where we want to turn off all checking and
-- in particular we want to allow long lines. So we reset this value to
-- Column_Number'Last during scanning of configuration pragma files.
Maximum_Processes : Positive := 1; Maximum_Processes : Positive := 1;
-- GNATMAKE, GPRMAKE -- GNATMAKE, GPRMAKE
-- Maximum number of processes that should be spawned to carry out -- Maximum number of processes that should be spawned to carry out
......
gcc/ada/s-finimp.adb
...@@ -594,6 +594,6 @@ package body System.Finalization_Implementation is ...@@ -594,6 +594,6 @@ package body System.Finalization_Implementation is
-- Initialization of package, set Adafinal soft link -- Initialization of package, set Adafinal soft link
begin begin
SSL.Adafinal := Finalize_Global_List'Access; SSL.Finalize_Global_List := Finalize_Global_List'Access;
end System.Finalization_Implementation; end System.Finalization_Implementation;
gcc/ada/s-io.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -33,6 +33,10 @@ ...@@ -33,6 +33,10 @@
package body System.IO is package body System.IO is
Current_Out : File_Type := Stdout;
pragma Atomic (Current_Out);
-- Current output file (modified by Set_Output)
-------------- --------------
-- New_Line -- -- New_Line --
-------------- --------------
...@@ -49,21 +53,35 @@ package body System.IO is ...@@ -49,21 +53,35 @@ package body System.IO is
--------- ---------
procedure Put (X : Integer) is procedure Put (X : Integer) is
procedure Put_Int (X : Integer); procedure Put_Int (X : Integer);
pragma Import (C, Put_Int, "put_int"); pragma Import (C, Put_Int, "put_int");
procedure Put_Int_Err (X : Integer);
pragma Import (C, Put_Int_Err, "put_int_stderr");
begin begin
Put_Int (X); case Current_Out is
when Stdout =>
Put_Int (X);
when Stderr =>
Put_Int_Err (X);
end case;
end Put; end Put;
procedure Put (C : Character) is procedure Put (C : Character) is
procedure Put_Char (C : Character); procedure Put_Char (C : Character);
pragma Import (C, Put_Char, "put_char"); pragma Import (C, Put_Char, "put_char");
procedure Put_Char_Stderr (C : Character);
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin begin
Put_Char (C); case Current_Out is
when Stdout =>
Put_Char (C);
when Stderr =>
Put_Char_Stderr (C);
end case;
end Put; end Put;
procedure Put (S : String) is procedure Put (S : String) is
...@@ -83,4 +101,31 @@ package body System.IO is ...@@ -83,4 +101,31 @@ package body System.IO is
New_Line; New_Line;
end Put_Line; end Put_Line;
---------------------
-- Standard_Output --
---------------------
function Standard_Output return File_Type is
begin
return Stdout;
end Standard_Output;
--------------------
-- Standard_Error --
--------------------
function Standard_Error return File_Type is
begin
return Stderr;
end Standard_Error;
----------------
-- Set_Output --
----------------
procedure Set_Output (File : in File_Type) is
begin
Current_Out := File;
end Set_Output;
end System.IO; end System.IO;
gcc/ada/s-io.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -48,4 +48,19 @@ package System.IO is ...@@ -48,4 +48,19 @@ package System.IO is
procedure New_Line (Spacing : Positive := 1); procedure New_Line (Spacing : Positive := 1);
type File_Type is limited private;
function Standard_Error return File_Type;
function Standard_Output return File_Type;
procedure Set_Output (File : in File_Type);
private
type File_Type is (Stdout, Stderr);
-- Stdout = Standard_Output, Stderr = Standard_Error
pragma Inline (Standard_Error);
pragma Inline (Standard_Output);
end System.IO; end System.IO;
gcc/ada/s-soflin.adb
...@@ -83,6 +83,25 @@ package body System.Soft_Links is ...@@ -83,6 +83,25 @@ package body System.Soft_Links is
null; null;
end Abort_Undefer_NT; end Abort_Undefer_NT;
-----------------
-- Adafinal_NT --
-----------------
procedure Adafinal_NT is
begin
-- Handle normal task termination by the environment task, but only
-- for the normal task termination. In the case of Abnormal and
-- Unhandled_Exception they must have been handled before, and the
-- task termination soft link must have been changed so the task
-- termination routine is not executed twice.
Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
-- Finalize the global list for controlled objects if needed
Finalize_Global_List.all;
end Adafinal_NT;
--------------------------- ---------------------------
-- Check_Abort_Status_NT -- -- Check_Abort_Status_NT --
--------------------------- ---------------------------
...@@ -226,14 +245,14 @@ package body System.Soft_Links is ...@@ -226,14 +245,14 @@ package body System.Soft_Links is
return NT_TSD.Pri_Stack_Info'Access; return NT_TSD.Pri_Stack_Info'Access;
end Get_Stack_Info_NT; end Get_Stack_Info_NT;
------------------- -------------------------------
-- Null_Adafinal -- -- Null_Finalize_Global_List --
------------------- -------------------------------
procedure Null_Adafinal is procedure Null_Finalize_Global_List is
begin begin
null; null;
end Null_Adafinal; end Null_Finalize_Global_List;
--------------------------- ---------------------------
-- Set_Jmpbuf_Address_NT -- -- Set_Jmpbuf_Address_NT --
...@@ -286,6 +305,16 @@ package body System.Soft_Links is ...@@ -286,6 +305,16 @@ package body System.Soft_Links is
end Task_Unlock_NT; end Task_Unlock_NT;
------------------------- -------------------------
-- Task_Termination_NT --
-------------------------
procedure Task_Termination_NT (Excep : EO) is
pragma Warnings (Off, Excep);
begin
null;
end Task_Termination_NT;
-------------------------
-- Update_Exception_NT -- -- Update_Exception_NT --
------------------------- -------------------------
......
gcc/ada/s-soflin.ads
...@@ -62,6 +62,7 @@ package System.Soft_Links is ...@@ -62,6 +62,7 @@ package System.Soft_Links is
type No_Param_Proc is access procedure; type No_Param_Proc is access procedure;
type Addr_Param_Proc is access procedure (Addr : Address); type Addr_Param_Proc is access procedure (Addr : Address);
type EO_Param_Proc is access procedure (Excep : EO);
type Get_Address_Call is access function return Address; type Get_Address_Call is access function return Address;
type Set_Address_Call is access procedure (Addr : Address); type Set_Address_Call is access procedure (Addr : Address);
...@@ -92,6 +93,7 @@ package System.Soft_Links is ...@@ -92,6 +93,7 @@ package System.Soft_Links is
pragma Suppress (Access_Check, No_Param_Proc); pragma Suppress (Access_Check, No_Param_Proc);
pragma Suppress (Access_Check, Addr_Param_Proc); pragma Suppress (Access_Check, Addr_Param_Proc);
pragma Suppress (Access_Check, EO_Param_Proc);
pragma Suppress (Access_Check, Get_Address_Call); pragma Suppress (Access_Check, Get_Address_Call);
pragma Suppress (Access_Check, Set_Address_Call); pragma Suppress (Access_Check, Set_Address_Call);
pragma Suppress (Access_Check, Set_Address_Call2); pragma Suppress (Access_Check, Set_Address_Call2);
...@@ -139,9 +141,15 @@ package System.Soft_Links is ...@@ -139,9 +141,15 @@ package System.Soft_Links is
procedure Task_Unlock_NT; procedure Task_Unlock_NT;
-- Release lock set by Task_Lock (non-tasking case, does nothing) -- Release lock set by Task_Lock (non-tasking case, does nothing)
procedure Null_Adafinal; procedure Task_Termination_NT (Excep : EO);
-- Shuts down the runtime system (non-tasking no-finalization case, -- Handle task termination routines for the environment task (non-tasking
-- does nothing) -- case, does nothing).
procedure Null_Finalize_Global_List;
-- Finalize global list for controlled objects (does nothing)
procedure Adafinal_NT;
-- Shuts down the runtime system (non-tasking case)
Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
pragma Suppress (Access_Check, Abort_Defer); pragma Suppress (Access_Check, Abort_Defer);
...@@ -197,7 +205,13 @@ package System.Soft_Links is ...@@ -197,7 +205,13 @@ package System.Soft_Links is
-- This ensures that the lock is not left set if an exception is raised -- This ensures that the lock is not left set if an exception is raised
-- explicitly or implicitly during the critical locked region. -- explicitly or implicitly during the critical locked region.
Adafinal : No_Param_Proc := Null_Adafinal'Access; Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
-- Handle task termination routines (task/non-task case as appropriate)
Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
-- Performs finalization of global list for controlled objects
Adafinal : No_Param_Proc := Adafinal_NT'Access;
-- Performs the finalization of the Ada Runtime -- Performs the finalization of the Ada Runtime
function Get_Jmpbuf_Address_NT return Address; function Get_Jmpbuf_Address_NT return Address;
......
gcc/ada/s-solita.adb
...@@ -46,12 +46,25 @@ with System.Task_Primitives.Operations; ...@@ -46,12 +46,25 @@ with System.Task_Primitives.Operations;
with System.Tasking; with System.Tasking;
-- Used for Task_Id -- Used for Task_Id
-- Cause_Of_Termination
with Ada.Exceptions;
-- Used for Exception_Id
-- Exception_Occurrence
-- Save_Occurrence
with Ada.Exceptions.Is_Null_Occurrence;
package body System.Soft_Links.Tasking is package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations; package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links; package SSL renames System.Soft_Links;
use Ada.Exceptions;
use type System.Tasking.Task_Id;
use type System.Tasking.Termination_Handler;
---------------- ----------------
-- Local Data -- -- Local Data --
---------------- ----------------
...@@ -78,6 +91,9 @@ package body System.Soft_Links.Tasking is ...@@ -78,6 +91,9 @@ package body System.Soft_Links.Tasking is
procedure Timed_Delay_T (Time : Duration; Mode : Integer); procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay -- Task-safe version of SSL.Timed_Delay
procedure Task_Termination_Handler_T (Excep : SSL.EO);
-- Task-safe version of the task termination procedure
-------------------------- --------------------------
-- Soft-Link Get Bodies -- -- Soft-Link Get Bodies --
-------------------------- --------------------------
...@@ -134,6 +150,48 @@ package body System.Soft_Links.Tasking is ...@@ -134,6 +150,48 @@ package body System.Soft_Links.Tasking is
end if; end if;
end Timed_Delay_T; end Timed_Delay_T;
--------------------------------
-- Task_Termination_Handler_T --
--------------------------------
procedure Task_Termination_Handler_T (Excep : SSL.EO) is
Self_Id : constant System.Tasking.Task_Id := STPO.Self;
Cause : System.Tasking.Cause_Of_Termination;
EO : Ada.Exceptions.Exception_Occurrence;
begin
-- We can only be here because we are terminating the environment task.
-- Task termination for the rest of the tasks is handled in the
-- Task_Wrapper.
pragma Assert (Self_Id = STPO.Environment_Task);
-- Normal task termination
if Is_Null_Occurrence (Excep) then
Cause := System.Tasking.Normal;
Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
-- Abnormal task termination
elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
Cause := System.Tasking.Abnormal;
Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
-- Termination because of an unhandled exception
else
Cause := System.Tasking.Unhandled_Exception;
Ada.Exceptions.Save_Occurrence (EO, Excep);
end if;
if Self_Id.Common.Specific_Handler /= null then
Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
elsif Self_Id.Common.Fall_Back_Handler /= null then
Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO);
end if;
end Task_Termination_Handler_T;
----------------------------- -----------------------------
-- Init_Tasking_Soft_Links -- -- Init_Tasking_Soft_Links --
----------------------------- -----------------------------
...@@ -151,12 +209,13 @@ package body System.Soft_Links.Tasking is ...@@ -151,12 +209,13 @@ package body System.Soft_Links.Tasking is
-- The application being executed uses tasking so that the tasking -- The application being executed uses tasking so that the tasking
-- version of the following soft links need to be used. -- version of the following soft links need to be used.
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access; SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Timed_Delay := Timed_Delay_T'Access; SSL.Timed_Delay := Timed_Delay_T'Access;
SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
-- No need to create a new Secondary Stack, since we will use the -- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb -- default one created in s-secsta.adb
......
gcc/ada/s-tasini.adb
...@@ -323,7 +323,7 @@ package body System.Tasking.Initialization is ...@@ -323,7 +323,7 @@ package body System.Tasking.Initialization is
procedure Final_Task_Unlock (Self_ID : Task_Id) is procedure Final_Task_Unlock (Self_ID : Task_Id) is
begin begin
pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1); pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1);
Unlock (Global_Task_Lock'Access, Global_Lock => True); Unlock (Global_Task_Lock'Access, Global_Lock => True);
end Final_Task_Unlock; end Final_Task_Unlock;
...@@ -624,9 +624,10 @@ package body System.Tasking.Initialization is ...@@ -624,9 +624,10 @@ package body System.Tasking.Initialization is
procedure Task_Lock (Self_ID : Task_Id) is procedure Task_Lock (Self_ID : Task_Id) is
begin begin
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1; Self_ID.Common.Global_Task_Lock_Nesting :=
Self_ID.Common.Global_Task_Lock_Nesting + 1;
if Self_ID.Global_Task_Lock_Nesting = 1 then if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
Defer_Abort_Nestable (Self_ID); Defer_Abort_Nestable (Self_ID);
Write_Lock (Global_Task_Lock'Access, Global_Lock => True); Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
end if; end if;
...@@ -654,10 +655,11 @@ package body System.Tasking.Initialization is ...@@ -654,10 +655,11 @@ package body System.Tasking.Initialization is
procedure Task_Unlock (Self_ID : Task_Id) is procedure Task_Unlock (Self_ID : Task_Id) is
begin begin
pragma Assert (Self_ID.Global_Task_Lock_Nesting > 0); pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1; Self_ID.Common.Global_Task_Lock_Nesting :=
Self_ID.Common.Global_Task_Lock_Nesting - 1;
if Self_ID.Global_Task_Lock_Nesting = 0 then if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
Unlock (Global_Task_Lock'Access, Global_Lock => True); Unlock (Global_Task_Lock'Access, Global_Lock => True);
Undefer_Abort_Nestable (Self_ID); Undefer_Abort_Nestable (Self_ID);
end if; end if;
......
gcc/ada/s-taskin.adb
...@@ -107,6 +107,9 @@ package body System.Tasking is ...@@ -107,6 +107,9 @@ package body System.Tasking is
T.Common.Elaborated := Elaborated; T.Common.Elaborated := Elaborated;
T.Common.Activation_Failed := False; T.Common.Activation_Failed := False;
T.Common.Task_Info := Task_Info; T.Common.Task_Info := Task_Info;
T.Common.Global_Task_Lock_Nesting := 0;
T.Common.Fall_Back_Handler := null;
T.Common.Specific_Handler := null;
if T.Common.Parent = null then if T.Common.Parent = null then
-- For the environment task, the adjusted stack size is -- For the environment task, the adjusted stack size is
......
gcc/ada/s-taskin.ads
...@@ -37,7 +37,8 @@ ...@@ -37,7 +37,8 @@
-- Any changes to this interface may require corresponding compiler changes. -- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions; with Ada.Exceptions;
-- Used for: Exception_Id -- Used for Exception_Id
-- Exception_Occurrence
with System.Parameters; with System.Parameters;
-- used for Size_Type -- used for Size_Type
...@@ -51,6 +52,9 @@ with System.Soft_Links; ...@@ -51,6 +52,9 @@ with System.Soft_Links;
with System.Task_Primitives; with System.Task_Primitives;
-- used for Private_Data -- used for Private_Data
with System.Stack_Usage;
-- used for Stack_Analyzer
with Unchecked_Conversion; with Unchecked_Conversion;
package System.Tasking is package System.Tasking is
...@@ -329,6 +333,32 @@ package System.Tasking is ...@@ -329,6 +333,32 @@ package System.Tasking is
end record; end record;
pragma Suppress_Initialization (Restricted_Entry_Call_Record); pragma Suppress_Initialization (Restricted_Entry_Call_Record);
-------------------------------------------
-- Task termination procedure definition --
-------------------------------------------
-- We need to redefine here these types (already defined in
-- Ada.Task_Termination) for avoiding circular dependencies.
type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception);
-- Possible causes for task termination:
--
-- Normal means that the task terminates due to completing the
-- last sentence of its body, or as a result of waiting on a
-- terminate alternative.
-- Abnormal means that the task terminates because it is being aborted
-- handled_Exception means that the task terminates because of exception
-- raised by by the execution of its task_body.
type Termination_Handler is access protected procedure
(Cause : in Cause_Of_Termination;
T : in Task_Id;
X : in Ada.Exceptions.Exception_Occurrence);
-- Used to represent protected procedures to be executed when task
-- terminates.
------------------------------------ ------------------------------------
-- Task related other definitions -- -- Task related other definitions --
------------------------------------ ------------------------------------
...@@ -539,6 +569,32 @@ package System.Tasking is ...@@ -539,6 +569,32 @@ package System.Tasking is
Task_Info : System.Task_Info.Task_Info_Type; Task_Info : System.Task_Info.Task_Info_Type;
-- System-specific attributes of the task as specified by the -- System-specific attributes of the task as specified by the
-- Task_Info pragma. -- Task_Info pragma.
Analyzer : System.Stack_Usage.Stack_Analyzer;
-- For storing informations used to measure the stack usage.
Global_Task_Lock_Nesting : Natural;
-- This is the current nesting level of calls to
-- System.Tasking.Initialization.Lock_Task. This allows a task to call
-- Lock_Task multiple times without deadlocking. A task only locks
-- Global_Task_Lock when its Global_Task_Lock_Nesting goes from 0 to 1,
-- and only unlocked when it goes from 1 to 0.
--
-- Protection: Only accessed by Self
Fall_Back_Handler : Termination_Handler;
pragma Atomic (Fall_Back_Handler);
-- This is the fall-back handler that applies to the dependent tasks of
-- the task.
--
-- Protection: atomic access
Specific_Handler : Termination_Handler;
pragma Atomic (Specific_Handler);
-- This is the specific handler that applies only to this task, and not
-- any of its dependent tasks.
--
-- Protection: atomic access
end record; end record;
--------------------------------------- ---------------------------------------
...@@ -796,15 +852,6 @@ package System.Tasking is ...@@ -796,15 +852,6 @@ package System.Tasking is
-- --
-- Protection: Self.L -- Protection: Self.L
Global_Task_Lock_Nesting : Natural := 0;
-- This is the current nesting level of calls to
-- System.Tasking.Stages.Lock_Task_T. This allows a task to call
-- Lock_Task_T multiple times without deadlocking. A task only locks
-- All_Task_Lock when its All_Tasks_Nesting goes from 0 to 1, and only
-- unlocked when it goes from 1 to 0.
--
-- Protection: Only accessed by Self
Open_Accepts : Accept_List_Access; Open_Accepts : Accept_List_Access;
-- This points to the Open_Accepts array of accept alternatives passed -- This points to the Open_Accepts array of accept alternatives passed
-- to the RTS by the compiler-generated code to Selective_Wait. It is -- to the RTS by the compiler-generated code to Selective_Wait. It is
......
gcc/ada/s-tasuti.adb
...@@ -117,9 +117,6 @@ package body System.Tasking.Utilities is ...@@ -117,9 +117,6 @@ package body System.Tasking.Utilities is
-- Abort_Tasks -- -- Abort_Tasks --
----------------- -----------------
-- Compiler interface only: Do not call from within the RTS,
-- except in the implementation of Ada.Task_Identification.
-- This must be called to implement the abort statement. -- This must be called to implement the abort statement.
-- Much of the actual work of the abort is done by the abortee, -- Much of the actual work of the abort is done by the abortee,
-- via the Abort_Handler signal handler, and propagation of the -- via the Abort_Handler signal handler, and propagation of the
...@@ -131,6 +128,17 @@ package body System.Tasking.Utilities is ...@@ -131,6 +128,17 @@ package body System.Tasking.Utilities is
P : Task_Id; P : Task_Id;
begin begin
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a
-- protected action.
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation");
end if;
Initialization.Defer_Abort_Nestable (Self_Id); Initialization.Defer_Abort_Nestable (Self_Id);
-- ????? -- ?????
......
gcc/ada/switch-b.adb
...@@ -286,6 +286,18 @@ package body Switch.B is ...@@ -286,6 +286,18 @@ package body Switch.B is
Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value, C); Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value, C);
Time_Slice_Value := Time_Slice_Value * 1_000; Time_Slice_Value := Time_Slice_Value * 1_000;
-- Processing for u switch
when 'u' =>
Ptr := Ptr + 1;
Dynamic_Stack_Measurement := True;
Scan_Nat
(Switch_Chars,
Max,
Ptr,
Dynamic_Stack_Measurement_Array_Size,
C);
-- Processing for v switch -- Processing for v switch
when 'v' => when 'v' =>
......
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