OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2004-07-06  Vincent Celier  <celier@gnat.com>

	* vms_conv.ads: Minor reformatting.
	Alphabetical order for enumerated values of type Command_Type, to have
	the command in alphabetical order for the usage.

	* vms_conv.adb (Process_Argument): Set Keep_Temporary_Files to True for
	the special qualifier /KEEP_TEMPORARY_FILES (minimum 6 characters).

	* gnat_ugn.texi: Document new switch -dn for the GNAT driver.

	* makegpr.adb (Global_Archive_Exists): New global Boolean variable
	(Add_Archive_Path): Only add the global archive if there is one.
	(Build_Global_Archive): Set Global_Archive_Exists depending if there is
	or not any object file to put in the global archive, and don't build
	a global archive if there is none.
	(X_Switches): New table
	(Compile_Link_With_Gnatmake): Pass to gnatmake the -X switches stored
	in the X_Switches table, if any.
	(Initialize): Make sure the X_Switches table is empty
	(Scan_Arg): Record -X switches in table X_Switches

	* opt.ads (Keep_Temporary_Files): New Boolean flag, defaulted to False.

	* make.adb: Minor comment fix

	* gnatname.adb (Gnatname): When not on VMS, and gnatname has been
	invoked with directory information, add the directory in front of the
	path.

	* gnatchop.adb (Gnatchop): When not on VMS, and gnatchop has been
	invoked with directory information, add the directory in front of the
	path.

	* gnatcmd.adb (Delete_Temp_Config_Files): Only delete temporary files
	when Keep_Temporary_Files is False.
	(GNATCmd): When not on VMS, and the GNAT driver has been invoked with
	directory information, add the directory in front of the path.
	When not on VMS, handle new switch -dn before the command to set
	Keep_Temporary_Files to True.
	(Non_VMS_Usage): Use lower case for the non VMS usage: this is valid
	everywhere.

	* gnatlink.adb (Gnatlink): When not on VMS, and gnatlink has been
	invoked with directory information, add the directory in front of the
	path.

2004-07-06  Thomas Quinot  <quinot@act-europe.fr>

	* snames.ads, snames.adb (Name_Stub): New name for the distributed
	systems annex.

	* rtsfind.ads: New RTE TC_Object, for DSA/PolyORB.
	New RTEs RAS_Proxy_Type and RAS_Proxy_Type_Access, for DSA.

	* g-socket.adb (To_Timeval): Fix incorrect conversion of
	Selector_Duration to Timeval for the case of 0.0.

	* exp_util.ads (Evolve_Or_Else): Fix overenthusiastic copy/paste of
	documentation from Evolve_And_Then.

2004-07-06  Jose Ruiz  <ruiz@act-europe.fr>

	* s-taprop-tru64.adb, s-taprop-os2.adb,
	s-taprop-mingw.adb, s-taprop-posix.adb: Update comment.

2004-07-06  Robert Dewar  <dewar@gnat.com>

	* s-osinte-hpux.ads, s-osinte-freebsd.ads,
	s-osinte-lynxos.ads, s-taprop-lynxos.adb, s-osinte-tru64.ads,
	s-osinte-aix.ads, s-osinte-irix.ads, s-taprop-irix.adb,
	s-interr-sigaction.adb, s-taprop-irix-athread.adb,
	s-osinte-hpux-dce.adb, s-taprop-hpux-dce.adb,
	s-taprop-linux.adb, s-taprop-dummy.adb, s-taprop-solaris.adb,
	s-interr-vms.adb, s-osinte-vms.ads, s-taprop-vms.adb,
	s-osinte-vxworks.ads, s-osprim-vxworks.adb, a-numaux-x86.adb,
	a-except.adb, a-exexpr.adb, a-intsig.adb, a-tags.adb,
	a-tags.ads, bindgen.ads, checks.adb, checks.adb,
	csets.ads, einfo.ads, einfo.ads, elists.adb, exp_ch4.adb,
	exp_ch7.adb, exp_dist.adb, exp_util.adb, freeze.adb,
	g-dynhta.adb, gnatmem.adb, g-regexp.adb, inline.adb,
	i-os2thr.ads, osint.adb, prj.adb, scng.adb, sem_cat.adb,
	sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, sem_ch7.adb,
	sem_ch8.adb, sem_disp.adb, sem_prag.adb, sem_res.adb,
	sem_type.adb, sem_type.ads, sem_warn.adb, s-ficobl.ads,
	s-finimp.adb, s-htable.adb, sinfo.ads, sinput-l.ads,
	s-interr.adb, s-interr.ads, sprint.adb, s-tarest.adb,
	s-tasini.ads, s-taskin.ads, s-taskin.ads, uname.adb,
	vms_data.ads: Minor reformatting,
	Fix bad box comment format.

	* gnat_rm.texi: Fix minor grammatical error

	* sem_attr.adb, exp_attr.adb: New attribute Has_Access_Values

	* sem_util.ads, sem_util.adb (Requires_Transient_Scope): Allow many
	more cases of discriminated records to be recognized as not needing a
	secondary stack.
	(Has_Access_Values): New function.

	* snames.h, snames.adb, snames.ads: New attribute Has_Access_Values

	* cstand.adb, layout.ads, layout.adb, sem_ch13.ads: Change name
	Set_Prim_Alignment to Set_Elem_Alignment (more accurate correspondence
	with LRM terminology).
	Change terminology in comments primitive type => elementary type.

2004-07-06  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15602
	* sem_ch7.adb (Unit_Requires_Body): For a generic package, the formal
	parameters do not impose any requirements on the presence of a body.

2004-07-06  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15593
	* sem_ch12.adb (Analyze_Package_Instantiation): If the generic is not a
	compilation unit and is in an open scope at the point of instantiation,
	assume that a body may be present later.

2004-07-06  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case 'Size):
	Improve error message when specified size is not supported.

	* sem_ch6.adb (Maybe_Primitive_Operation): A library-level subprogram
	is never a primitive operation.

From-SVN: r84152
This commit is contained in:
Arnaud Charlet 2004-07-06 15:57:33 +02:00
parent ef5732117a
commit 15ce9ca22b
102 changed files with 2141 additions and 1707 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
gcc/ada/ChangeLog
View File

@ -1,3 +1,131 @@
2004-07-06 Vincent Celier <celier@gnat.com>
* vms_conv.ads: Minor reformatting.
Alphabetical order for enumerated values of type Command_Type, to have
the command in alphabetical order for the usage.
* vms_conv.adb (Process_Argument): Set Keep_Temporary_Files to True for
the special qualifier /KEEP_TEMPORARY_FILES (minimum 6 characters).
* gnat_ugn.texi: Document new switch -dn for the GNAT driver.
* makegpr.adb (Global_Archive_Exists): New global Boolean variable
(Add_Archive_Path): Only add the global archive if there is one.
(Build_Global_Archive): Set Global_Archive_Exists depending if there is
or not any object file to put in the global archive, and don't build
a global archive if there is none.
(X_Switches): New table
(Compile_Link_With_Gnatmake): Pass to gnatmake the -X switches stored
in the X_Switches table, if any.
(Initialize): Make sure the X_Switches table is empty
(Scan_Arg): Record -X switches in table X_Switches
* opt.ads (Keep_Temporary_Files): New Boolean flag, defaulted to False.
* make.adb: Minor comment fix
* gnatname.adb (Gnatname): When not on VMS, and gnatname has been
invoked with directory information, add the directory in front of the
path.
* gnatchop.adb (Gnatchop): When not on VMS, and gnatchop has been
invoked with directory information, add the directory in front of the
path.
* gnatcmd.adb (Delete_Temp_Config_Files): Only delete temporary files
when Keep_Temporary_Files is False.
(GNATCmd): When not on VMS, and the GNAT driver has been invoked with
directory information, add the directory in front of the path.
When not on VMS, handle new switch -dn before the command to set
Keep_Temporary_Files to True.
(Non_VMS_Usage): Use lower case for the non VMS usage: this is valid
everywhere.
* gnatlink.adb (Gnatlink): When not on VMS, and gnatlink has been
invoked with directory information, add the directory in front of the
path.
2004-07-06 Thomas Quinot <quinot@act-europe.fr>
* snames.ads, snames.adb (Name_Stub): New name for the distributed
systems annex.
* rtsfind.ads: New RTE TC_Object, for DSA/PolyORB.
New RTEs RAS_Proxy_Type and RAS_Proxy_Type_Access, for DSA.
* g-socket.adb (To_Timeval): Fix incorrect conversion of
Selector_Duration to Timeval for the case of 0.0.
* exp_util.ads (Evolve_Or_Else): Fix overenthusiastic copy/paste of
documentation from Evolve_And_Then.
2004-07-06 Jose Ruiz <ruiz@act-europe.fr>
* s-taprop-tru64.adb, s-taprop-os2.adb,
s-taprop-mingw.adb, s-taprop-posix.adb: Update comment.
2004-07-06 Robert Dewar <dewar@gnat.com>
* s-osinte-hpux.ads, s-osinte-freebsd.ads,
s-osinte-lynxos.ads, s-taprop-lynxos.adb, s-osinte-tru64.ads,
s-osinte-aix.ads, s-osinte-irix.ads, s-taprop-irix.adb,
s-interr-sigaction.adb, s-taprop-irix-athread.adb,
s-osinte-hpux-dce.adb, s-taprop-hpux-dce.adb,
s-taprop-linux.adb, s-taprop-dummy.adb, s-taprop-solaris.adb,
s-interr-vms.adb, s-osinte-vms.ads, s-taprop-vms.adb,
s-osinte-vxworks.ads, s-osprim-vxworks.adb, a-numaux-x86.adb,
a-except.adb, a-exexpr.adb, a-intsig.adb, a-tags.adb,
a-tags.ads, bindgen.ads, checks.adb, checks.adb,
csets.ads, einfo.ads, einfo.ads, elists.adb, exp_ch4.adb,
exp_ch7.adb, exp_dist.adb, exp_util.adb, freeze.adb,
g-dynhta.adb, gnatmem.adb, g-regexp.adb, inline.adb,
i-os2thr.ads, osint.adb, prj.adb, scng.adb, sem_cat.adb,
sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, sem_ch7.adb,
sem_ch8.adb, sem_disp.adb, sem_prag.adb, sem_res.adb,
sem_type.adb, sem_type.ads, sem_warn.adb, s-ficobl.ads,
s-finimp.adb, s-htable.adb, sinfo.ads, sinput-l.ads,
s-interr.adb, s-interr.ads, sprint.adb, s-tarest.adb,
s-tasini.ads, s-taskin.ads, s-taskin.ads, uname.adb,
vms_data.ads: Minor reformatting,
Fix bad box comment format.
* gnat_rm.texi: Fix minor grammatical error
* sem_attr.adb, exp_attr.adb: New attribute Has_Access_Values
* sem_util.ads, sem_util.adb (Requires_Transient_Scope): Allow many
more cases of discriminated records to be recognized as not needing a
secondary stack.
(Has_Access_Values): New function.
* snames.h, snames.adb, snames.ads: New attribute Has_Access_Values
* cstand.adb, layout.ads, layout.adb, sem_ch13.ads: Change name
Set_Prim_Alignment to Set_Elem_Alignment (more accurate correspondence
with LRM terminology).
Change terminology in comments primitive type => elementary type.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
PR ada/15602
* sem_ch7.adb (Unit_Requires_Body): For a generic package, the formal
parameters do not impose any requirements on the presence of a body.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
PR ada/15593
* sem_ch12.adb (Analyze_Package_Instantiation): If the generic is not a
compilation unit and is in an open scope at the point of instantiation,
assume that a body may be present later.
2004-07-06 Ed Schonberg <schonberg@gnat.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case 'Size):
Improve error message when specified size is not supported.
* sem_ch6.adb (Maybe_Primitive_Operation): A library-level subprogram
is never a primitive operation.
2004-07-05 Andreas Schwab <schwab@suse.de>
* ada-tree.h (TYPE_LEFT_JUSTIFIED_MODULAR_P): Use

6
gcc/ada/a-except.adb
View File

@ -122,9 +122,9 @@ package body Ada.Exceptions is
package Exception_Data is
----------------------------------
-- Exception messages routines --
----------------------------------
---------------------------------
-- Exception messages routines --
---------------------------------
procedure Set_Exception_C_Msg
(Id : Exception_Id;

6
gcc/ada/a-exexpr.adb
View File

@ -122,9 +122,9 @@ package body Exception_Propagation is
-- maximally aligned (see unwind.h). See additional comments on the
-- alignment below.
---------------------------------------------------------------
-- GNAT specific entities to deal with the GCC eh circuitry --
---------------------------------------------------------------
--------------------------------------------------------------
-- GNAT Specific Entities To Deal With The GCC EH Circuitry --
--------------------------------------------------------------
-- A GNAT exception object to be dealt with by the personality routine
-- called by the GCC unwinding runtime.

8
gcc/ada/a-intsig.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2000-2004 Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -34,9 +34,9 @@
with System.Interrupt_Management.Operations;
package body Ada.Interrupts.Signal is
-------------------------
-- Generate_Interrupt --
-------------------------
------------------------
-- Generate_Interrupt --
------------------------
procedure Generate_Interrupt (Interrupt : Interrupt_ID) is
begin

6
gcc/ada/a-numaux-x86.adb
View File

@ -62,9 +62,9 @@ package body Ada.Numerics.Aux is
pragma Inline (Is_Nan);
pragma Inline (Reduce);
---------------------------------
-- Basic Elementary Functions --
---------------------------------
--------------------------------
-- Basic Elementary Functions --
--------------------------------
-- This section implements a few elementary functions that are used to
-- build the more complex ones. This ordering enables better inlining.

6
gcc/ada/a-tags.adb
View File

@ -221,9 +221,9 @@ package body Ada.Tags is
end HTable_Subprograms;
--------------------
-- CW_Membership --
--------------------
-------------------
-- CW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:

6
gcc/ada/a-tags.ads
View File

@ -55,9 +55,9 @@ package Ada.Tags is
private
----------------------------------------------------------------
-- Abstract procedural interface for the GNAT dispatch table --
----------------------------------------------------------------
---------------------------------------------------------------
-- Abstract Procedural Interface For The GNAT Dispatch Table --
---------------------------------------------------------------
-- GNAT's Dispatch Table format is customizable in order to match the
-- format used in another langauge. GNAT supports programs that use

6
gcc/ada/bindgen.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -35,10 +35,6 @@
package Bindgen is
------------------
-- Subprograms --
------------------
procedure Gen_Output_File (Filename : String);
-- Filename is the full path name of the binder output file

8
gcc/ada/checks.adb
View File

@ -909,7 +909,7 @@ package body Checks is
if Static and then Siz >= Check_Siz then
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Object_Too_Large));
Reason => SE_Object_Too_Large));
Error_Msg_N ("?Storage_Error will be raised at run-time", N);
Uintp.Release (Umark);
return;
@ -4070,9 +4070,9 @@ package body Checks is
Reason => CE_Discriminant_Check_Failed));
end Generate_Discriminant_Check;
----------------------------
-- Generate_Index_Checks --
----------------------------
---------------------------
-- Generate_Index_Checks --
---------------------------
procedure Generate_Index_Checks (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);

8
gcc/ada/csets.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -51,9 +51,9 @@ pragma Elaborate_Body (Csets);
-- do NOT pack this table, since we don't want the extra overhead of
-- accessing a packed bit string.
-----------------------------------------------
-- Character Tables For Current Compilation --
-----------------------------------------------
----------------------------------------------
-- Character Tables For Current Compilation --
----------------------------------------------
procedure Initialize;
-- Routine to initialize following character tables, whose content depends

42
gcc/ada/cstand.adb
View File

@ -145,7 +145,7 @@ package body CStand is
Set_Ekind (E, E_Floating_Point_Type);
Set_Etype (E, E);
Init_Size (E, Siz);
Set_Prim_Alignment (E);
Set_Elem_Alignment (E);
Init_Digits_Value (E, Digs);
Set_Float_Bounds (E);
Set_Is_Frozen (E);
@ -171,7 +171,7 @@ package body CStand is
Set_Ekind (E, E_Signed_Integer_Type);
Set_Etype (E, E);
Init_Size (E, Siz);
Set_Prim_Alignment (E);
Set_Elem_Alignment (E);
Set_Integer_Bounds (E, E, Lbound, Ubound);
Set_Is_Frozen (E);
Set_Is_Public (E);
@ -358,7 +358,7 @@ package body CStand is
Set_Etype (Standard_Boolean, Standard_Boolean);
Init_Esize (Standard_Boolean, Standard_Character_Size);
Init_RM_Size (Standard_Boolean, 1);
Set_Prim_Alignment (Standard_Boolean);
Set_Elem_Alignment (Standard_Boolean);
Set_Is_Unsigned_Type (Standard_Boolean);
Set_Size_Known_At_Compile_Time (Standard_Boolean);
@ -480,7 +480,7 @@ package body CStand is
Set_Etype (Standard_Character, Standard_Character);
Init_Esize (Standard_Character, Standard_Character_Size);
Init_RM_Size (Standard_Character, 8);
Set_Prim_Alignment (Standard_Character);
Set_Elem_Alignment (Standard_Character);
Set_Is_Unsigned_Type (Standard_Character);
Set_Is_Character_Type (Standard_Character);
@ -526,7 +526,7 @@ package body CStand is
Set_Etype (Standard_Wide_Character, Standard_Wide_Character);
Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size);
Set_Prim_Alignment (Standard_Wide_Character);
Set_Elem_Alignment (Standard_Wide_Character);
Set_Is_Unsigned_Type (Standard_Wide_Character);
Set_Is_Character_Type (Standard_Wide_Character);
Set_Is_Known_Valid (Standard_Wide_Character);
@ -636,7 +636,7 @@ package body CStand is
Set_Etype (Standard_Natural, Base_Type (Standard_Integer));
Init_Esize (Standard_Natural, Standard_Integer_Size);
Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1);
Set_Prim_Alignment (Standard_Natural);
Set_Elem_Alignment (Standard_Natural);
Set_Size_Known_At_Compile_Time
(Standard_Natural);
Set_Integer_Bounds (Standard_Natural,
@ -659,7 +659,7 @@ package body CStand is
Set_Etype (Standard_Positive, Base_Type (Standard_Integer));
Init_Esize (Standard_Positive, Standard_Integer_Size);
Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1);
Set_Prim_Alignment (Standard_Positive);
Set_Elem_Alignment (Standard_Positive);
Set_Size_Known_At_Compile_Time (Standard_Positive);
@ -777,7 +777,7 @@ package body CStand is
Set_Scope (Standard_A_Char, Standard_Standard);
Set_Etype (Standard_A_Char, Standard_A_String);
Init_Size (Standard_A_Char, System_Address_Size);
Set_Prim_Alignment (Standard_A_Char);
Set_Elem_Alignment (Standard_A_Char);
Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
Make_Name (Standard_A_Char, "access_character");
@ -811,7 +811,7 @@ package body CStand is
Set_Scope (Any_Access, Standard_Standard);
Set_Etype (Any_Access, Any_Access);
Init_Size (Any_Access, System_Address_Size);
Set_Prim_Alignment (Any_Access);
Set_Elem_Alignment (Any_Access);
Make_Name (Any_Access, "an access type");
Any_Character := New_Standard_Entity;
@ -822,7 +822,7 @@ package body CStand is
Set_Is_Character_Type (Any_Character);
Init_Esize (Any_Character, Standard_Character_Size);
Init_RM_Size (Any_Character, 8);
Set_Prim_Alignment (Any_Character);
Set_Elem_Alignment (Any_Character);
Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
Make_Name (Any_Character, "a character type");
@ -840,7 +840,7 @@ package body CStand is
Set_Etype (Any_Boolean, Standard_Boolean);
Init_Esize (Any_Boolean, Standard_Character_Size);
Init_RM_Size (Any_Boolean, 1);
Set_Prim_Alignment (Any_Boolean);
Set_Elem_Alignment (Any_Boolean);
Set_Is_Unsigned_Type (Any_Boolean);
Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
Make_Name (Any_Boolean, "a boolean type");
@ -859,7 +859,7 @@ package body CStand is
Set_Scope (Any_Discrete, Standard_Standard);
Set_Etype (Any_Discrete, Any_Discrete);
Init_Size (Any_Discrete, Standard_Integer_Size);
Set_Prim_Alignment (Any_Discrete);
Set_Elem_Alignment (Any_Discrete);
Make_Name (Any_Discrete, "a discrete type");
Any_Fixed := New_Standard_Entity;
@ -867,7 +867,7 @@ package body CStand is
Set_Scope (Any_Fixed, Standard_Standard);
Set_Etype (Any_Fixed, Any_Fixed);
Init_Size (Any_Fixed, Standard_Integer_Size);
Set_Prim_Alignment (Any_Fixed);
Set_Elem_Alignment (Any_Fixed);
Make_Name (Any_Fixed, "a fixed-point type");
Any_Integer := New_Standard_Entity;
@ -875,7 +875,7 @@ package body CStand is
Set_Scope (Any_Integer, Standard_Standard);
Set_Etype (Any_Integer, Standard_Long_Long_Integer);
Init_Size (Any_Integer, Standard_Long_Long_Integer_Size);
Set_Prim_Alignment (Any_Integer);
Set_Elem_Alignment (Any_Integer);
Set_Integer_Bounds
(Any_Integer,
@ -889,7 +889,7 @@ package body CStand is
Set_Scope (Any_Modular, Standard_Standard);
Set_Etype (Any_Modular, Standard_Long_Long_Integer);
Init_Size (Any_Modular, Standard_Long_Long_Integer_Size);
Set_Prim_Alignment (Any_Modular);
Set_Elem_Alignment (Any_Modular);
Set_Is_Unsigned_Type (Any_Modular);
Make_Name (Any_Modular, "a modular type");
@ -898,7 +898,7 @@ package body CStand is
Set_Scope (Any_Numeric, Standard_Standard);
Set_Etype (Any_Numeric, Standard_Long_Long_Integer);
Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size);
Set_Prim_Alignment (Any_Numeric);
Set_Elem_Alignment (Any_Numeric);
Make_Name (Any_Numeric, "a numeric type");
Any_Real := New_Standard_Entity;
@ -906,7 +906,7 @@ package body CStand is
Set_Scope (Any_Real, Standard_Standard);
Set_Etype (Any_Real, Standard_Long_Long_Float);
Init_Size (Any_Real, Standard_Long_Long_Float_Size);
Set_Prim_Alignment (Any_Real);
Set_Elem_Alignment (Any_Real);
Make_Name (Any_Real, "a real type");
Any_Scalar := New_Standard_Entity;
@ -914,7 +914,7 @@ package body CStand is
Set_Scope (Any_Scalar, Standard_Standard);
Set_Etype (Any_Scalar, Any_Scalar);
Init_Size (Any_Scalar, Standard_Integer_Size);
Set_Prim_Alignment (Any_Scalar);
Set_Elem_Alignment (Any_Scalar);
Make_Name (Any_Scalar, "a scalar type");
Any_String := New_Standard_Entity;
@ -974,7 +974,7 @@ package body CStand is
Set_Scope (Standard_Unsigned, Standard_Standard);
Set_Etype (Standard_Unsigned, Standard_Unsigned);
Init_Size (Standard_Unsigned, Standard_Integer_Size);
Set_Prim_Alignment (Standard_Unsigned);
Set_Elem_Alignment (Standard_Unsigned);
Set_Modulus (Standard_Unsigned,
Uint_2 ** Standard_Integer_Size);
Set_Is_Unsigned_Type (Standard_Unsigned);
@ -1023,7 +1023,7 @@ package body CStand is
Set_Etype (Universal_Fixed, Universal_Fixed);
Set_Scope (Universal_Fixed, Standard_Standard);
Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size);
Set_Prim_Alignment (Universal_Fixed);
Set_Elem_Alignment (Universal_Fixed);
Set_Size_Known_At_Compile_Time
(Universal_Fixed);
@ -1073,7 +1073,7 @@ package body CStand is
Init_Size (Standard_Duration, 64);
end if;
Set_Prim_Alignment (Standard_Duration);
Set_Elem_Alignment (Standard_Duration);
Set_Delta_Value (Standard_Duration, Delta_Val);
Set_Small_Value (Standard_Duration, Delta_Val);
Set_Scalar_Range (Standard_Duration,

8
gcc/ada/einfo.ads
View File

@ -2922,7 +2922,7 @@ package Einfo is
-- is needed, since returns an invalid value in this case!
-- Sec_Stack_Needed_For_Return (Flag167)
-- Present in scope entities (blocks,functions, procedures, tasks,
-- Present in scope entities (blocks, functions, procedures, tasks,
-- entries). Set to True when secondary stack is used to hold
-- the returned value of a function and thus should not be
-- released on scope exit.
@ -4967,9 +4967,9 @@ package Einfo is
subtype L is Elist_Id;
subtype S is List_Id;
---------------------------------
-- Attribute Access Functions --
---------------------------------
--------------------------------
-- Attribute Access Functions --
--------------------------------
-- All attributes are manipulated through a procedural interface. This
-- section contains the functions used to obtain attribute values which

8
gcc/ada/elists.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -79,9 +79,9 @@ package body Elists is
-- is the last item in the list. The Node field points to the node which
-- is referenced by the corresponding list entry.
--------------------------
-- Element List Tables --
--------------------------
-------------------------
-- Element List Tables --
-------------------------
type Elist_Header is record
First : Elmt_Id;

1
gcc/ada/exp_attr.adb
View File

@ -4035,6 +4035,7 @@ package body Exp_Attr is
Attribute_Digits |
Attribute_Emax |
Attribute_Epsilon |
Attribute_Has_Access_Values |
Attribute_Has_Discriminants |
Attribute_Large |
Attribute_Machine_Emax |

6
gcc/ada/exp_ch4.adb
View File

@ -66,9 +66,9 @@ with Validsw; use Validsw;
package body Exp_Ch4 is
------------------------
-- Local Subprograms --
------------------------
-----------------------
-- Local Subprograms --
-----------------------
procedure Binary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Binary_Op_Validity_Checks);

99
gcc/ada/exp_ch7.adb
View File

@ -130,8 +130,7 @@ package body Exp_Ch7 is
Is_Master : Boolean;
Is_Protected_Subprogram : Boolean;
Is_Task_Allocation_Block : Boolean;
Is_Asynchronous_Call_Block : Boolean)
return Node_Id;
Is_Asynchronous_Call_Block : Boolean) return Node_Id;
-- Expand a the clean-up procedure for controlled and/or transient
-- block, and/or task master or task body, or blocks used to
-- implement task allocation or asynchronous entry calls, or
@ -153,8 +152,7 @@ package body Exp_Ch7 is
function Make_Transient_Block
(Loc : Source_Ptr;
Action : Node_Id)
return Node_Id;
Action : Node_Id) return Node_Id;
-- Create a transient block whose name is Scope, which is also a
-- controlled block if Flist is not empty and whose only code is
-- Action (either a single statement or single declaration).
@ -184,8 +182,7 @@ package body Exp_Ch7 is
function Make_Deep_Proc
(Prim : Final_Primitives;
Typ : Entity_Id;
Stmts : List_Id)
return Node_Id;
Stmts : List_Id) return Node_Id;
-- This function generates the tree for Deep_Initialize, Deep_Adjust
-- or Deep_Finalize procedures according to the first parameter,
-- these procedures operate on the type Typ. The Stmts parameter
@ -193,8 +190,7 @@ package body Exp_Ch7 is
function Make_Deep_Array_Body
(Prim : Final_Primitives;
Typ : Entity_Id)
return List_Id;
Typ : Entity_Id) return List_Id;
-- This function generates the list of statements for implementing
-- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
-- according to the first parameter, these procedures operate on the
@ -202,8 +198,7 @@ package body Exp_Ch7 is
function Make_Deep_Record_Body
(Prim : Final_Primitives;
Typ : Entity_Id)
return List_Id;
Typ : Entity_Id) return List_Id;
-- This function generates the list of statements for implementing
-- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
-- according to the first parameter, these procedures operate on the
@ -230,8 +225,7 @@ package body Exp_Ch7 is
function Convert_View
(Proc : Entity_Id;
Arg : Node_Id;
Ind : Pos := 1)
return Node_Id;
Ind : Pos := 1) return Node_Id;
-- Proc is one of the Initialize/Adjust/Finalize operations, and
-- Arg is the argument being passed to it. Ind indicates which
-- formal of procedure Proc we are trying to match. This function
@ -503,8 +497,7 @@ package body Exp_Ch7 is
function Cleanup_Array
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id)
return List_Id
Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Index_List : constant List_Id := New_List;
@ -601,8 +594,7 @@ package body Exp_Ch7 is
function Cleanup_Record
(N : Node_Id;
Obj : Node_Id;
Typ : Entity_Id)
return List_Id
Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Tsk : Node_Id;
@ -671,14 +663,13 @@ package body Exp_Ch7 is
return Stmts;
end Cleanup_Record;
-------------------------------
-- Cleanup_Protected_Object --
-------------------------------
------------------------------
-- Cleanup_Protected_Object --
------------------------------
function Cleanup_Protected_Object
(N : Node_Id;
Ref : Node_Id)
return Node_Id
(N : Node_Id;
Ref : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
@ -747,9 +738,8 @@ package body Exp_Ch7 is
------------------
function Cleanup_Task
(N : Node_Id;
Ref : Node_Id)
return Node_Id
(N : Node_Id;
Ref : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
begin
@ -852,12 +842,12 @@ package body Exp_Ch7 is
-- If type is not frozen yet, check explicitly among its components,
-- because flag is not necessarily set.
------------------------------------
-- Has_Some_Controlled_Component --
------------------------------------
-----------------------------------
-- Has_Some_Controlled_Component --
-----------------------------------
function Has_Some_Controlled_Component (Rec : Entity_Id)
return Boolean
function Has_Some_Controlled_Component
(Rec : Entity_Id) return Boolean
is
Comp : Entity_Id;
@ -966,8 +956,7 @@ package body Exp_Ch7 is
function Convert_View
(Proc : Entity_Id;
Arg : Node_Id;
Ind : Pos := 1)
return Node_Id
Ind : Pos := 1) return Node_Id
is
Fent : Entity_Id := First_Entity (Proc);
Ftyp : Entity_Id;
@ -1424,9 +1413,8 @@ package body Exp_Ch7 is
Len_Ref : Node_Id := Empty;
function Last_Array_Component
(Ref : Node_Id;
Typ : Entity_Id)
return Node_Id;
(Ref : Node_Id;
Typ : Entity_Id) return Node_Id;
-- Creates a reference to the last component of the array object
-- designated by Ref whose type is Typ.
@ -1435,9 +1423,8 @@ package body Exp_Ch7 is
--------------------------
function Last_Array_Component
(Ref : Node_Id;
Typ : Entity_Id)
return Node_Id
(Ref : Node_Id;
Typ : Entity_Id) return Node_Id
is
Index_List : constant List_Id := New_List;
@ -1685,9 +1672,8 @@ package body Exp_Ch7 is
---------------------
function Find_Final_List
(E : Entity_Id;
Ref : Node_Id := Empty)
return Node_Id
(E : Entity_Id;
Ref : Node_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Ref);
S : Entity_Id;
@ -2020,8 +2006,7 @@ package body Exp_Ch7 is
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return List_Id
With_Attach : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Ref);
Res : constant List_Id := New_List;
@ -2131,10 +2116,9 @@ package body Exp_Ch7 is
-- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
function Make_Attach_Call
(Obj_Ref : Node_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return Node_Id
(Obj_Ref : Node_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
@ -2170,8 +2154,7 @@ package body Exp_Ch7 is
Is_Master : Boolean;
Is_Protected_Subprogram : Boolean;
Is_Task_Allocation_Block : Boolean;
Is_Asynchronous_Call_Block : Boolean)
return Node_Id
Is_Asynchronous_Call_Block : Boolean) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Clean);
Stmt : constant List_Id := New_List;
@ -2477,8 +2460,7 @@ package body Exp_Ch7 is
function Make_Deep_Array_Body
(Prim : Final_Primitives;
Typ : Entity_Id)
return List_Id
Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
@ -2588,8 +2570,7 @@ package body Exp_Ch7 is
function Make_Deep_Proc
(Prim : Final_Primitives;
Typ : Entity_Id;
Stmts : List_Id)
return Entity_Id
Stmts : List_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Formals : List_Id;
@ -2664,8 +2645,7 @@ package body Exp_Ch7 is
function Make_Deep_Record_Body
(Prim : Final_Primitives;
Typ : Entity_Id)
return List_Id
Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Controller_Typ : Entity_Id;
@ -2767,8 +2747,7 @@ package body Exp_Ch7 is
function Make_Final_Call
(Ref : Node_Id;
Typ : Entity_Id;
With_Detach : Node_Id)
return List_Id
With_Detach : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Ref);
Res : constant List_Id := New_List;
@ -2893,8 +2872,7 @@ package body Exp_Ch7 is
(Ref : Node_Id;
Typ : Entity_Id;
Flist_Ref : Node_Id;
With_Attach : Node_Id)
return List_Id
With_Attach : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Ref);
Is_Conc : Boolean;
@ -3012,8 +2990,7 @@ package body Exp_Ch7 is
function Make_Transient_Block
(Loc : Source_Ptr;
Action : Node_Id)
return Node_Id
Action : Node_Id) return Node_Id
is
Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
Decls : constant List_Id := New_List;

12
gcc/ada/exp_dist.adb
View File

@ -538,14 +538,14 @@ package body Exp_Dist is
end if;
end Add_RACW_Features;
-------------------------------------------------
-- Add_RACW_Primitive_Declarations_And_Bodies --
-------------------------------------------------
------------------------------------------------
-- Add_RACW_Primitive_Declarations_And_Bodies --
------------------------------------------------
procedure Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type : in Entity_Id;
Insertion_Node : in Node_Id;
Decls : in List_Id)
(Designated_Type : Entity_Id;
Insertion_Node : Node_Id;
Decls : List_Id)
is
-- Set sloc of generated declaration to be that of the
-- insertion node, so the declarations are recognized as

6
gcc/ada/exp_util.adb
View File

@ -327,9 +327,9 @@ package body Exp_Util is
end if;
end Build_Runtime_Call;
-----------------------------
-- Build_Task_Array_Image --
-----------------------------
----------------------------
-- Build_Task_Array_Image --
----------------------------
-- This function generates the body for a function that constructs the
-- image string for a task that is an array component. The function is

2
gcc/ada/exp_util.ads
View File

@ -320,7 +320,7 @@ package Exp_Util is
-- Empty, then simply returns Cond1 (this allows the use of Empty to
-- initialize a series of checks evolved by this routine, with a final
-- result of Empty indicating that no checks were required). The Sloc
-- field of the constructed N_And_Then node is copied from Cond1.
-- field of the constructed N_Or_Else node is copied from Cond1.
procedure Expand_Subtype_From_Expr
(N : Node_Id;

6
gcc/ada/freeze.adb
View File

@ -4398,9 +4398,9 @@ package body Freeze is
end if;
end Freeze_Subprogram;
-----------------------
-- Is_Fully_Defined --
-----------------------
----------------------
-- Is_Fully_Defined --
----------------------
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin

14
gcc/ada/g-dynhta.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- Copyright (C) 2002-2004 Ada Core Technologies, 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- --
@ -34,9 +34,9 @@
with Ada.Unchecked_Deallocation;
package body GNAT.Dynamic_HTables is
--------------------
-- Static_HTable --
--------------------
-------------------
-- Static_HTable --
-------------------
package body Static_HTable is
@ -207,9 +207,9 @@ package body GNAT.Dynamic_HTables is
end Set;
end Static_HTable;
--------------------
-- Simple_HTable --
--------------------
-------------------
-- Simple_HTable --
-------------------
package body Simple_HTable is

10
gcc/ada/g-regexp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2004 Ada Core Technologies, 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- --
@ -191,9 +191,9 @@ package body GNAT.Regexp is
procedure Add_In_Map (C : Character);
-- Add a character in the mapping, if it is not already defined
-----------------
-- Add_In_Map --
-----------------
----------------
-- Add_In_Map --
----------------
procedure Add_In_Map (C : Character) is
begin
@ -419,7 +419,7 @@ package body GNAT.Regexp is
-- end-state) :
--
-- regexp state_num | a b * empty_string
-- ------- ---------------------------------------
-- ------- ------------------------------
-- a 1 (s) | 2 - - -
-- 2 (e) | - - - -
--

14
gcc/ada/g-socket.adb
View File

@ -2130,8 +2130,18 @@ package body GNAT.Sockets is
MS : Timeval_Unit;
begin
S := Timeval_Unit (Val - 0.5);
MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
-- If zero, set result as zero (otherwise it gets rounded down to -1)
if Val = 0.0 then
S := 0;
MS := 0;
-- Normal case where we do round down
else
S := Timeval_Unit (Val - 0.5);
MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
end if;
return (S, MS);
end To_Timeval;

2
gcc/ada/gnat_rm.texi
View File

@ -8390,7 +8390,7 @@ Similarly, the size of type @code{Rec} is 40 bits
(@code{Rec'Size} = @code{Rec'Value_Size} = 40), but
the alignment is 4, so objects of this type will have
their size increased to 64 bits so that it is a multiple
of the alignment (in bits). The reason for this decision, which is
of the alignment (in bits). This decision is
in accordance with the specific Implementation Advice in RM 13.3(43):
@quotation

17
gcc/ada/gnat_ugn.texi
View File

@ -13234,8 +13234,21 @@ XREF to invoke @command{^gnatxref^gnatxref^}
@end itemize
@noindent
Note that the compiler is invoked using the command
@command{^gnatmake -f -u -c^gnatmake -f -u -c^}.
(note that the compiler is invoked using the command
@command{^gnatmake -f -u -c^gnatmake -f -u -c^}).
@noindent
On non VMS platforms, between @command{gnat} and the command, two
special switches may be used:
@itemize @bullet
@item
@command{-v} to display the invocation of the tool.
@item
@command{-dn} to prevent the @command{gnat} driver from removing
the temporary files it has created. These temporary files are
configuration files and temporary file list files.
@end itemize
@noindent
The command may be followed by switches and arguments for the invoked

32
gcc/ada/gnatchop.adb
View File

@ -1672,6 +1672,38 @@ procedure Gnatchop is
-- Start of processing for gnatchop
begin
-- Add the directory where gnatchop is invoked in front of the
-- path, if gnatchop is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.
if not Hostparm.OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir &
Path_Separator &
Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
exit;
end if;
end loop;
end;
end if;
-- Process command line options and initialize global variables
if not Scan_Arguments then

104
gcc/ada/gnatcmd.adb
View File

@ -30,7 +30,7 @@ with Csets;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
with Namet; use Namet;
with Opt;
with Opt; use Opt;
with Osint; use Osint;
with Output;
with Prj; use Prj;
@ -470,29 +470,32 @@ procedure GNATCmd is
Success : Boolean;
begin
if Project /= No_Project then
for Prj in 1 .. Projects.Last loop
if Projects.Table (Prj).Config_File_Temp then
if Opt.Verbose_Mode then
Output.Write_Str ("Deleting temp configuration file """);
Output.Write_Str (Get_Name_String
(Projects.Table (Prj).Config_File_Name));
Output.Write_Line ("""");
if not Keep_Temporary_Files then
if Project /= No_Project then
for Prj in 1 .. Projects.Last loop
if Projects.Table (Prj).Config_File_Temp then
if Verbose_Mode then
Output.Write_Str ("Deleting temp configuration file """);
Output.Write_Str
(Get_Name_String
(Projects.Table (Prj).Config_File_Name));
Output.Write_Line ("""");
end if;
Delete_File
(Name => Get_Name_String
(Projects.Table (Prj).Config_File_Name),
Success => Success);
end if;
end loop;
end if;
Delete_File
(Name => Get_Name_String
(Projects.Table (Prj).Config_File_Name),
Success => Success);
end if;
end loop;
end if;
-- If a temporary text file that contains a list of files for a tool
-- has been created, delete this temporary file.
-- If a temporary text file that contains a list of files for a tool
-- has been created, delete this temporary file.
if Temp_File_Name /= null then
Delete_File (Temp_File_Name.all, Success);
if Temp_File_Name /= null then
Delete_File (Temp_File_Name.all, Success);
end if;
end if;
end Delete_Temp_Config_Files;
@ -919,7 +922,7 @@ procedure GNATCmd is
for C in Command_List'Range loop
if not Command_List (C).VMS_Only then
Put ("GNAT " & Command_List (C).Cname.all);
Put ("gnat " & To_Lower (Command_List (C).Cname.all));
Set_Col (25);
Put (Command_List (C).Unixcmd.all);
@ -939,7 +942,7 @@ procedure GNATCmd is
end loop;
New_Line;
Put_Line ("Commands FIND, LIST, PRETTY, STUB, NETRIC and XREF accept " &
Put_Line ("Commands find, list, metric, pretty, stub and xref accept " &
"project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
@ -966,6 +969,38 @@ begin
VMS_Conv.Initialize;
-- Add the directory where the GNAT driver is invoked in front of the
-- path, if the GNAT driver is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.
if not OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir &
Path_Separator &
Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
exit;
end if;
end loop;
end;
end if;
-- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
-- filenames and pathnames to Unix style.
@ -982,10 +1017,23 @@ begin
return;
else
begin
if Argument_Count > 1 and then Argument (1) = "-v" then
Opt.Verbose_Mode := True;
Command_Arg := 2;
end if;
loop
if Argument_Count > Command_Arg
and then Argument (Command_Arg) = "-v"
then
Verbose_Mode := True;
Command_Arg := Command_Arg + 1;
elsif Argument_Count > Command_Arg
and then Argument (Command_Arg) = "-dn"
then
Keep_Temporary_Files := True;
Command_Arg := Command_Arg + 1;
else
exit;
end if;
end loop;
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
@ -1623,7 +1671,7 @@ begin
raise Normal_Exit;
end if;
if Opt.Verbose_Mode then
if Verbose_Mode then
Output.Write_Str (Exec_Path.all);
for Arg in The_Args'Range loop

32
gcc/ada/gnatlink.adb
View File

@ -1297,6 +1297,38 @@ procedure Gnatlink is
-- Start of processing for Gnatlink
begin
-- Add the directory where gnatlink is invoked in front of the
-- path, if gnatlink is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.
if not Hostparm.OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir &
Path_Separator &
Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
exit;
end if;
end loop;
end;
end if;
Process_Args;
if Argument_Count = 0

6
gcc/ada/gnatmem.adb
View File

@ -147,9 +147,9 @@ procedure Gnatmem is
Tmp_Alloc : Allocation;
Quiet_Mode : Boolean := False;
-------------------------------
-- Allocation roots sorting --
-------------------------------
------------------------------
-- Allocation Roots Sorting --
------------------------------
Sort_Order : String (1 .. 3) := "nwh";
-- This is the default order in which sorting criteria will be applied

34
gcc/ada/gnatname.adb
View File

@ -25,12 +25,14 @@
------------------------------------------------------------------------------
with Gnatvsn;
with Hostparm;
with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Makr;
with Table;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@ -296,6 +298,38 @@ procedure Gnatname is
-- Start of processing for Gnatname
begin
-- Add the directory where gnatname is invoked in front of the
-- path, if gnatname is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.
if not Hostparm.OpenVMS then
declare
Command : constant String := Command_Name;
begin
for Index in reverse Command'Range loop
if Command (Index) = Directory_Separator then
declare
Absolute_Dir : constant String :=
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String :=
Absolute_Dir &
Path_Separator &
Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
exit;
end if;
end loop;
end;
end if;
-- Initialize tables
Excluded_Patterns.Set_Last (0);

20
gcc/ada/i-os2thr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1993-1997 Free Software Foundation, Inc. --
-- Copyright (C) 1993-2004 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- --
@ -63,8 +63,7 @@ pragma Preelaborate (Threads);
pfn : PFNTHREAD;
param : PVOID;
flag : ULONG;
cbStack : ULONG)
return APIRET;
cbStack : ULONG) return APIRET;
pragma Import (C, DosCreateThread, "DosCreateThread");
Block_Child : constant := 1;
@ -152,8 +151,7 @@ pragma Preelaborate (Threads);
function DosGetInfoBlocks
(Pptib : access PTIB;
Pppib : access PPIB)
return APIRET;
Pppib : access PPIB) return APIRET;
pragma Import (C, DosGetInfoBlocks, "DosGetInfoBlocks");
-- Thread local memory
@ -164,23 +162,21 @@ pragma Preelaborate (Threads);
function DosAllocThreadLocalMemory
(cb : ULONG; -- Number of 4-byte DWORDs to allocate
p : access PVOID) -- Address of the memory block
return
APIRET; -- Return Code (rc)
return APIRET; -- Return Code (rc)
pragma Import
(Convention => C,
Entity => DosAllocThreadLocalMemory,
Link_Name => "_DosAllocThreadLocalMemory");
-----------------
-- Priorities --
-----------------
----------------
-- Priorities --
----------------
function DosSetPriority
(Scope : ULONG;
Class : ULONG;
Delta_P : IC.long;
PorTid : TID)
return APIRET;
PorTid : TID) return APIRET;
pragma Import (C, DosSetPriority, "DosSetPriority");
PRTYS_PROCESS : constant := 0;

6
gcc/ada/inline.adb
View File

@ -701,9 +701,9 @@ package body Inline is
end if;
end Analyze_Inlined_Bodies;
--------------------------------
-- Check_Body_For_Inlining --
--------------------------------
-----------------------------
-- Check_Body_For_Inlining --
-----------------------------
procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
Bname : Unit_Name_Type;

12
gcc/ada/layout.adb
View File

@ -2347,7 +2347,7 @@ package body Layout is
end;
end if;
Set_Prim_Alignment (E);
Set_Elem_Alignment (E);
-- Scalar types: set size and alignment
@ -2412,9 +2412,9 @@ package body Layout is
end if;
end if;
Set_Prim_Alignment (E);
Set_Elem_Alignment (E);
-- Non-primitive types
-- Non-elementary (composite) types
else
-- If RM_Size is known, set Esize if not known
@ -2864,10 +2864,10 @@ package body Layout is
end Set_Discrete_RM_Size;
------------------------
-- Set_Prim_Alignment --
-- Set_Elem_Alignment --
------------------------
procedure Set_Prim_Alignment (E : Entity_Id) is
procedure Set_Elem_Alignment (E : Entity_Id) is
begin
-- Do not set alignment for packed array types, unless we are doing
-- front end layout, because otherwise this is always handled in the
@ -2930,7 +2930,7 @@ package body Layout is
Init_Alignment (E, A);
end if;
end;
end Set_Prim_Alignment;
end Set_Elem_Alignment;
----------------------
-- SO_Ref_From_Expr --

12
gcc/ada/layout.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
-- Copyright (C) 2000-2004 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- --
@ -68,10 +68,10 @@ package Layout is
-- types, the RM_Size is simply set to zero. This routine also sets
-- the Is_Constrained flag in Def_Id.
procedure Set_Prim_Alignment (E : Entity_Id);
-- The front end always sets alignments for primitive types by calling this
-- procedure. Note that we have to do this for discrete types (since the
-- Alignment attribute is static), so we might as well do it for all
-- scalar types, since the processing is the same.
procedure Set_Elem_Alignment (E : Entity_Id);
-- The front end always sets alignments for elementary types by calling
-- this procedure. Note that we have to do this for discrete types (since
-- the Alignment attribute is static), so we might as well do it for all
-- elementary types, since the processing is the same.
end Layout;

2
gcc/ada/make.adb
View File

@ -5626,7 +5626,7 @@ package body Make is
Mains.Delete;
-- Add the directory where gnatmake is invoked in the front of the
-- Add the directory where gnatmake is invoked in front of the
-- path, if gnatmake is invoked with directory information.
-- Only do this if the platform is not VMS, where the notion of path
-- does not really exist.

172
gcc/ada/makegpr.adb
View File

@ -212,6 +212,15 @@ package body Makegpr is
Hash => Hash,
Equal => "=");
package X_Switches is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 2,
Table_Increment => 100,
Table_Name => "Makegpr.X_Switches");
-- Table to store the -X switches to be passed to gnatmake
Initial_Argument_Count : constant Positive := 20;
type Boolean_Array is array (Positive range <>) of Boolean;
type Booleans is access Boolean_Array;
@ -305,6 +314,10 @@ package body Makegpr is
Need_To_Relink : Boolean := False;
-- True when an executable of a language other than Ada need to be linked
Global_Archive_Exists : Boolean := False;
-- True if there is a non empty global archive, to prevent creation
-- of such archives.
Path_Option : String_Access;
-- The path option switch, when supported
@ -567,9 +580,9 @@ package body Makegpr is
end if;
-- For a non-library project, the only archive needed
-- is the one for the main project.
-- is the one for the main project, if there is one.
elsif Project = Main_Project then
elsif Project = Main_Project and then Global_Archive_Exists then
Add_Argument
(Get_Name_String (Data.Object_Directory) &
Directory_Separator &
@ -1157,11 +1170,6 @@ package body Makegpr is
-- Archive needs to be rebuilt
else
-- If the archive is built, then linking will need to occur
-- unconditionally.
Need_To_Relink := True;
-- If archive already exists, first delete it
-- Comment needed on why we discard result???
@ -1208,86 +1216,100 @@ package body Makegpr is
end if;
end loop;
-- Spawn the archive builder (ar)
-- No need to create a global archive, if there is no object
-- file to put into.
Saved_Last_Argument := Last_Argument;
Global_Archive_Exists := Last_Argument > First_Object;
Last_Argument := First_Object + Max_In_Archives;
if Global_Archive_Exists then
-- If the archive is built, then linking will need to occur
-- unconditionally.
loop
if Last_Argument > Saved_Last_Argument then
Last_Argument := Saved_Last_Argument;
end if;
Need_To_Relink := True;
Display_Command (Archive_Builder, Archive_Builder_Path);
-- Spawn the archive builder (ar)
Spawn
(Archive_Builder_Path.all,
Arguments (1 .. Last_Argument),
Success);
Saved_Last_Argument := Last_Argument;
exit when not Success;
Last_Argument := First_Object + Max_In_Archives;
exit when Last_Argument = Saved_Last_Argument;
loop
if Last_Argument > Saved_Last_Argument then
Last_Argument := Saved_Last_Argument;
end if;
Arguments (1) := r;
Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) :=
Arguments (Last_Argument + 1 .. Saved_Last_Argument);
Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2;
end loop;
Display_Command (Archive_Builder, Archive_Builder_Path);
-- If the archive was built, run the archive indexer (ranlib)
-- if there is one.
Spawn
(Archive_Builder_Path.all,
Arguments (1 .. Last_Argument),
Success);
if Success then
exit when not Success;
-- If the archive was built, run the archive indexer (ranlib),
exit when Last_Argument = Saved_Last_Argument;
Arguments (1) := r;
Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) :=
Arguments (Last_Argument + 1 .. Saved_Last_Argument);
Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2;
end loop;
-- If the archive was built, run the archive indexer (ranlib)
-- if there is one.
if Archive_Indexer_Path /= null then
Last_Argument := 0;
Add_Argument (Archive_Name, True);
if Success then
Display_Command (Archive_Indexer, Archive_Indexer_Path);
-- If the archive was built, run the archive indexer (ranlib),
-- if there is one.
Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
if Archive_Indexer_Path /= null then
Last_Argument := 0;
Add_Argument (Archive_Name, True);
if not Success then
Display_Command (Archive_Indexer, Archive_Indexer_Path);
-- Running ranlib failed, delete the dependency file,
-- if it exists.
Spawn
(Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
if not Success then
-- Running ranlib failed, delete the dependency file,
-- if it exists.
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
end if;
-- And report the error
Report_Error
("running" & Archive_Indexer & " for project """,
Get_Name_String (Data.Name),
""" failed");
return;
end if;
-- And report the error
Report_Error
("running" & Archive_Indexer & " for project """,
Get_Name_String (Data.Name),
""" failed");
return;
end if;
-- The archive was correctly built, create its dependency file
Create_Global_Archive_Dependency_File (Archive_Dep_Name);
-- Building the archive failed, delete dependency file if one
-- exists.
else
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
end if;
-- And report the error
Report_Error
("building archive for project """,
Get_Name_String (Data.Name),
""" failed");
end if;
-- The archive was correctly built, create its dependency file
Create_Global_Archive_Dependency_File (Archive_Dep_Name);
-- Building the archive failed, delete dependency file if one exists
else
if Is_Regular_File (Archive_Dep_Name) then
Delete_File (Archive_Dep_Name, Success);
end if;
-- And report the error
Report_Error
("building archive for project """,
Get_Name_String (Data.Name),
""" failed");
end if;
end if;
end Build_Global_Archive;
@ -2316,6 +2338,12 @@ package body Makegpr is
Add_Argument (Dash_P, True);
Add_Argument (Get_Name_String (Data.Path_Name), True);
-- Add the -X switches, if any
for Index in 1 .. X_Switches.Last loop
Add_Argument (X_Switches.Table (Index), True);
end loop;
-- If Mains_Specified is True, find the mains in package Mains
if Mains_Specified then
@ -3008,6 +3036,10 @@ package body Makegpr is
Add_Str_To_Name_Buffer ("compiler_command");
Name_Compiler_Command := Name_Find;
-- Make sure the -X switch table is empty
X_Switches.Set_Last (0);
-- Get the command line arguments
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
@ -3807,7 +3839,7 @@ package body Makegpr is
Osint.Fail
("switch -o not allowed within a -largs. Use -o directly.");
-- If current processor is not gprmake dirrectly, store the option in
-- If current processor is not gprmake directly, store the option in
-- the appropriate table.
elsif Current_Processor /= None then
@ -3877,7 +3909,11 @@ package body Makegpr is
then
-- Is_External_Assignment has side effects when it returns True
null;
-- Record the -X switch, so that they can be passed to gnatmake,
-- if gnatmake is called.
X_Switches.Increment_Last;
X_Switches.Table (X_Switches.Last) := new String'(Arg);
else
Osint.Fail ("illegal option """, Arg, """");

5
gcc/ada/opt.ads
View File

@ -560,6 +560,11 @@ package Opt is
-- When True signals gnatmake to ignore compilation errors and keep
-- processing sources until there is no more work.
Keep_Temporary_Files : Boolean := False;
-- GNATCMD
-- When True the temporary files created by the GNAT driver are not
-- deleted. Set by switch -dn or qualifier /KEEP_TEMPORARY_FILES.
Link_Only : Boolean := False;
-- GNATMAKE
-- Set to True to skip compile and bind steps

6
gcc/ada/osint.adb
View File

@ -1176,9 +1176,9 @@ package body Osint is
return Src_Search_Directories.Table (Primary_Directory);
end Get_Primary_Src_Search_Directory;
-------------------------
-- Get_RTS_Search_Dir --
-------------------------
------------------------
-- Get_RTS_Search_Dir --
------------------------
function Get_RTS_Search_Dir
(Search_Dir : String;

6
gcc/ada/prj.adb
View File

@ -376,9 +376,9 @@ package body Prj is
end if;
end Register_Default_Naming_Scheme;
------------
-- Reset --
------------
-----------
-- Reset --
-----------
procedure Reset is
begin

6
gcc/ada/rtsfind.ads
View File

@ -1012,6 +1012,8 @@ package Rtsfind is
RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface
RE_RACW_Stub_Type, -- System.Partition_Interface
RE_RACW_Stub_Type_Access, -- System.Partition_Interface
RE_RAS_Proxy_Type, -- System.Partition_Interface
RE_RAS_Proxy_Type_Access, -- System.Partition_Interface
RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
RE_Register_Passive_Package, -- System.Partition_Interface
RE_Register_Receiving_Stub, -- System.Partition_Interface
@ -1158,6 +1160,7 @@ package Rtsfind is
RE_TC_String, -- System.PolyORB_Interface,
RE_TC_Struct, -- System.PolyORB_Interface,
RE_TC_Union, -- System.PolyORB_Interface,
RE_TC_Object, -- System.PolyORB_Interface,
RE_IS_Is1, -- System.Scalar_Values
RE_IS_Is2, -- System.Scalar_Values
@ -2089,6 +2092,8 @@ package Rtsfind is
RE_Get_Unique_Remote_Pointer => System_Partition_Interface,
RE_RACW_Stub_Type => System_Partition_Interface,
RE_RACW_Stub_Type_Access => System_Partition_Interface,
RE_RAS_Proxy_Type => System_Partition_Interface,
RE_RAS_Proxy_Type_Access => System_Partition_Interface,
RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface,
RE_Register_Passive_Package => System_Partition_Interface,
RE_Register_Receiving_Stub => System_Partition_Interface,
@ -2223,6 +2228,7 @@ package Rtsfind is
RE_TC_String => System_PolyORB_Interface,
RE_TC_Struct => System_PolyORB_Interface,
RE_TC_Union => System_PolyORB_Interface,
RE_TC_Object => System_PolyORB_Interface,
RE_Global_Pool_Object => System_Pool_Global,

8
gcc/ada/s-ficobl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -42,9 +42,9 @@ with Interfaces.C_Streams;
package System.File_Control_Block is
-----------------------------
-- Ada File Control Block --
-----------------------------
----------------------------
-- Ada File Control Block --
----------------------------
-- The Ada file control block is an abstract extension of the root
-- stream type. This allows a file to be treated directly as a stream

6
gcc/ada/s-finimp.adb
View File

@ -91,9 +91,9 @@ package body System.Finalization_Implementation is
-- Given the address (obj) of a tagged object, return a
-- pointer to the record controller of this object.
-------------
-- Adjust --
-------------
------------
-- Adjust --
------------
procedure Adjust (Object : in out Record_Controller) is

6
gcc/ada/s-htable.adb
View File

@ -35,9 +35,9 @@ with Ada.Unchecked_Deallocation;
package body System.HTable is
--------------------
-- Static_HTable --
--------------------
-------------------
-- Static_HTable --
-------------------
package body Static_HTable is

6
gcc/ada/s-interr-sigaction.adb
View File

@ -255,9 +255,9 @@ package body System.Interrupts is
return True;
end Has_Interrupt_Or_Attach_Handler;
----------------
-- Finalize --
----------------
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Static_Interrupt_Protection) is
begin

30
gcc/ada/s-interr-vms.adb
View File

@ -192,9 +192,9 @@ package body System.Interrupts is
type Server_Task_Access is access Server_Task;
--------------------------------
-- Local Types and Variables --
--------------------------------
-------------------------------
-- Local Types and Variables --
-------------------------------
type Entry_Assoc is record
T : Task_Id;
@ -406,8 +406,9 @@ package body System.Interrupts is
-- Current_Handler --
---------------------
function Current_Handler (Interrupt : Interrupt_ID)
return Parameterless_Handler is
function Current_Handler
(Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@ -626,9 +627,9 @@ package body System.Interrupts is
task body Interrupt_Manager is
---------------------
-- Local Routines --
---------------------
--------------------
-- Local Routines --
--------------------
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
@ -1079,8 +1080,7 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
(Object : access Dynamic_Interrupt_Protection)
return Boolean
(Object : access Dynamic_Interrupt_Protection) return Boolean
is
pragma Warnings (Off, Object);
@ -1088,14 +1088,15 @@ package body System.Interrupts is
return True;
end Has_Interrupt_Or_Attach_Handler;
----------------
-- Finalize --
----------------
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Static_Interrupt_Protection) is
begin
-- ??? loop to be executed only when we're not doing library level
-- finalization, since in this case all interrupt tasks are gone.
if not Interrupt_Manager'Terminated then
for N in reverse Object.Previous_Handlers'Range loop
Interrupt_Manager.Attach_Handler
@ -1115,8 +1116,7 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
(Object : access Static_Interrupt_Protection)
return Boolean
(Object : access Static_Interrupt_Protection) return Boolean
is
pragma Warnings (Off, Object);
begin

12
gcc/ada/s-interr.adb
View File

@ -707,18 +707,18 @@ package body System.Interrupts is
task body Interrupt_Manager is
----------------------
-- Local Variables --
----------------------
---------------------
-- Local Variables --
---------------------
Intwait_Mask : aliased IMNG.Interrupt_Mask;
Ret_Interrupt : Interrupt_ID;
Old_Mask : aliased IMNG.Interrupt_Mask;
Old_Handler : Parameterless_Handler;
---------------------
-- Local Routines --
---------------------
--------------------
-- Local Routines --
--------------------
procedure Bind_Handler (Interrupt : Interrupt_ID);
-- This procedure does not do anything if the Interrupt is blocked.

18
gcc/ada/s-interr.ads
View File

@ -122,25 +122,25 @@ package System.Interrupts is
(Interrupt : Interrupt_ID)
return System.Address;
---------------------------------
-- Interrupt entries services --
---------------------------------
--------------------------------
-- Interrupt Entries Services --
--------------------------------
-- Routines needed for Interrupt Entries
-- Attempt to bind an Entry to an Interrupt to which a Handler is
-- already attached will raise a Program_Error.
procedure Bind_Interrupt_To_Entry
(T : System.Tasking.Task_Id;
E : System.Tasking.Task_Entry_Index;
Int_Ref : System.Address);
-- Bind the given interrupt to the given entry. If the interrupt is
-- already bound to another entry, Program_Error will be raised.
procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id);
-- This procedure detaches all the Interrupt Entries bound to a task.
-------------------------------
-- POSIX.5 signals services --
-------------------------------
------------------------------
-- POSIX.5 Signals Services --
------------------------------
-- Routines needed for POSIX dot5 POSIX_Signals
@ -177,7 +177,7 @@ package System.Interrupts is
-- This will make all the tasks in RTS blocked for the Interrupt.
----------------------
-- Protection types --
-- Protection Types --
----------------------
-- Routines and types needed to implement Interrupt_Handler and

12
gcc/ada/s-osinte-aix.ads
View File

@ -391,9 +391,9 @@ package System.OS_Interface is
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
----------------------------
-- POSIX.1c Section 13 --
----------------------------
--------------------------
-- POSIX.1c Section 13 --
--------------------------
PTHREAD_PRIO_NONE : constant := 0;
PTHREAD_PRIO_PROTECT : constant := 0;
@ -445,9 +445,9 @@ package System.OS_Interface is
function sched_yield return int;
-- AiX have a nonstandard sched_yield.
---------------------------
-- P1003.1c - Section 16 --
---------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "pthread_attr_init");

59
gcc/ada/s-osinte-freebsd.ads
View File

@ -328,18 +328,20 @@ package System.OS_Interface is
(addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
-----------------------------------------
-- Nonstandard Thread Initialization --
-----------------------------------------
-- FSU_THREADS requires pthread_init, which is nonstandard
-- and this should be invoked during the elaboration of s-taprop.adb
--
-- FreeBSD does not require this so we provide an empty Ada body.
---------------------------------------
-- Nonstandard Thread Initialization --
---------------------------------------
-- FSU_THREADS requires pthread_init, which is nonstandard and
-- this should be invoked during the elaboration of s-taprop.adb
-- FreeBSD does not require this so we provide an empty Ada body
procedure pthread_init;
---------------------------
-- POSIX.1c Section 3 --
---------------------------
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function sigwait
(set : access sigset_t;
@ -348,7 +350,7 @@ package System.OS_Interface is
function pthread_kill
(thread : pthread_t;
sig : Signal) return int;
sig : Signal) return int;
pragma Import (C, pthread_kill, "pthread_kill");
type sigset_t_ptr is access all sigset_t;
@ -359,9 +361,9 @@ package System.OS_Interface is
oset : sigset_t_ptr) return int;
pragma Import (C, pthread_sigmask, "pthread_sigmask");
----------------------------
-- POSIX.1c Section 11 --
----------------------------
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
@ -418,9 +420,9 @@ package System.OS_Interface is
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
----------------------------
-- POSIX.1c Section 13 --
----------------------------
--------------------------
-- POSIX.1c Section 13 --
--------------------------
PTHREAD_PRIO_NONE : constant := 0;
PTHREAD_PRIO_PROTECT : constant := 2;
@ -516,9 +518,9 @@ package System.OS_Interface is
function sched_yield return int;
pragma Import (C, sched_yield, "pthread_yield");
-----------------------------
-- P1003.1c - Section 16 --
-----------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "pthread_attr_init");
@ -567,9 +569,9 @@ package System.OS_Interface is
function pthread_self return pthread_t;
pragma Import (C, pthread_self, "pthread_self");
----------------------------
-- POSIX.1c Section 17 --
----------------------------
--------------------------
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
(key : pthread_key_t;
@ -587,9 +589,9 @@ package System.OS_Interface is
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "pthread_key_create");
--------------------------------------
-- Non-portable pthread functions --
--------------------------------------
------------------------------------
-- Non-portable Pthread Functions --
------------------------------------
function pthread_set_name_np
(thread : pthread_t;
@ -605,11 +607,12 @@ private
-- #define sa_handler __sigaction_u._handler
-- #define sa_sigaction __sigaction_u._sigaction
-- Should we add a signal_context type here ?
-- How could it be done independent of the CPU architecture ?
-- Should we add a signal_context type here ???
-- How could it be done independent of the CPU architecture ???
-- sigcontext type is opaque, so it is architecturally neutral.
-- It is always passed as an access type, so define it as an empty record
-- since the contents are not used anywhere.
type struct_sigcontext is null record;
pragma Convention (C, struct_sigcontext);

126
gcc/ada/s-osinte-hpux-dce.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- GNARL 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- --
@ -104,14 +104,13 @@ package body System.OS_Interface is
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
---------------------------
-- POSIX.1c Section 3 --
---------------------------
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function sigwait
(set : access sigset_t;
sig : access Signal)
return int
sig : access Signal) return int
is
Result : int;
@ -135,21 +134,18 @@ package body System.OS_Interface is
return 0;
end pthread_kill;
----------------------------
-- POSIX.1c Section 11 --
----------------------------
--------------------------
-- POSIX.1c Section 11 --
--------------------------
-- For all the following functions, DCE Threads has a non standard
-- behavior: it sets errno but the standard Posix requires it to be
-- returned.
-- For all following functions, DCE Threads has a non standard behavior.
-- It sets errno but the standard Posix requires it to be returned.
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t)
return int
(attr : access pthread_mutexattr_t) return int
is
function pthread_mutexattr_create
(attr : access pthread_mutexattr_t)
return int;
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
begin
@ -161,12 +157,10 @@ package body System.OS_Interface is
end pthread_mutexattr_init;
function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t)
return int
(attr : access pthread_mutexattr_t) return int
is
function pthread_mutexattr_delete
(attr : access pthread_mutexattr_t)
return int;
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
begin
@ -179,13 +173,11 @@ package body System.OS_Interface is
function pthread_mutex_init
(mutex : access pthread_mutex_t;
attr : access pthread_mutexattr_t)
return int
attr : access pthread_mutexattr_t) return int
is
function pthread_mutex_init_base
(mutex : access pthread_mutex_t;
attr : pthread_mutexattr_t)
return int;
attr : pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
begin
@ -197,12 +189,10 @@ package body System.OS_Interface is
end pthread_mutex_init;
function pthread_mutex_destroy
(mutex : access pthread_mutex_t)
return int
(mutex : access pthread_mutex_t) return int
is
function pthread_mutex_destroy_base
(mutex : access pthread_mutex_t)
return int;
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
begin
@ -214,12 +204,10 @@ package body System.OS_Interface is
end pthread_mutex_destroy;
function pthread_mutex_lock
(mutex : access pthread_mutex_t)
return int
(mutex : access pthread_mutex_t) return int
is
function pthread_mutex_lock_base
(mutex : access pthread_mutex_t)
return int;
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
begin
@ -231,12 +219,10 @@ package body System.OS_Interface is
end pthread_mutex_lock;
function pthread_mutex_unlock
(mutex : access pthread_mutex_t)
return int
(mutex : access pthread_mutex_t) return int
is
function pthread_mutex_unlock_base
(mutex : access pthread_mutex_t)
return int;
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
begin
@ -248,12 +234,10 @@ package body System.OS_Interface is
end pthread_mutex_unlock;
function pthread_condattr_init
(attr : access pthread_condattr_t)
return int
(attr : access pthread_condattr_t) return int
is
function pthread_condattr_create
(attr : access pthread_condattr_t)
return int;
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
begin
@ -265,12 +249,10 @@ package body System.OS_Interface is
end pthread_condattr_init;
function pthread_condattr_destroy
(attr : access pthread_condattr_t)
return int
(attr : access pthread_condattr_t) return int
is
function pthread_condattr_delete
(attr : access pthread_condattr_t)
return int;
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
begin
@ -283,13 +265,11 @@ package body System.OS_Interface is
function pthread_cond_init
(cond : access pthread_cond_t;
attr : access pthread_condattr_t)
return int
attr : access pthread_condattr_t) return int
is
function pthread_cond_init_base
(cond : access pthread_cond_t;
attr : pthread_condattr_t)
return int;
attr : pthread_condattr_t) return int;
pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
begin
@ -301,12 +281,10 @@ package body System.OS_Interface is
end pthread_cond_init;
function pthread_cond_destroy
(cond : access pthread_cond_t)
return int
(cond : access pthread_cond_t) return int
is
function pthread_cond_destroy_base
(cond : access pthread_cond_t)
return int;
(cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
begin
@ -318,12 +296,10 @@ package body System.OS_Interface is
end pthread_cond_destroy;
function pthread_cond_signal
(cond : access pthread_cond_t)
return int
(cond : access pthread_cond_t) return int
is
function pthread_cond_signal_base
(cond : access pthread_cond_t)
return int;
(cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
begin
@ -336,13 +312,11 @@ package body System.OS_Interface is
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t)
return int
mutex : access pthread_mutex_t) return int
is
function pthread_cond_wait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t)
return int;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
begin
@ -356,14 +330,12 @@ package body System.OS_Interface is
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec)
return int
abstime : access timespec) return int
is
function pthread_cond_timedwait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec)
return int;
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
begin
@ -390,8 +362,7 @@ package body System.OS_Interface is
function pthread_setscheduler
(thread : pthread_t;
policy : int;
priority : int)
return int;
priority : int) return int;
pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
begin
@ -414,11 +385,11 @@ package body System.OS_Interface is
-- P1003.1c - Section 16 --
-----------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int
function pthread_attr_init
(attributes : access pthread_attr_t) return int
is
function pthread_attr_create
(attributes : access pthread_attr_t)
return int;
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_create, "pthread_attr_create");
begin
@ -433,8 +404,7 @@ package body System.OS_Interface is
(attributes : access pthread_attr_t) return int
is
function pthread_attr_delete
(attributes : access pthread_attr_t)
return int;
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
begin
@ -451,8 +421,7 @@ package body System.OS_Interface is
is
function pthread_attr_setstacksize_base
(attr : access pthread_attr_t;
stacksize : size_t)
return int;
stacksize : size_t) return int;
pragma Import (C, pthread_attr_setstacksize_base,
"pthread_attr_setstacksize");
@ -474,8 +443,7 @@ package body System.OS_Interface is
(thread : access pthread_t;
attributes : pthread_attr_t;
start_routine : Thread_Body;
arg : System.Address)
return int;
arg : System.Address) return int;
pragma Import (C, pthread_create_base, "pthread_create");
begin
@ -488,9 +456,9 @@ package body System.OS_Interface is
end if;
end pthread_create;
----------------------------
-- POSIX.1c Section 17 --
----------------------------
--------------------------
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
(key : pthread_key_t;
@ -543,7 +511,6 @@ package body System.OS_Interface is
function Get_Stack_Base (thread : pthread_t) return Address is
pragma Warnings (Off, thread);
begin
return Null_Address;
end Get_Stack_Base;
@ -556,7 +523,6 @@ package body System.OS_Interface is
function intr_attach (sig : int; handler : isr_address) return long is
function c_signal (sig : int; handler : isr_address) return long;
pragma Import (C, c_signal, "signal");
begin
return c_signal (sig, handler);
end intr_attach;

12
gcc/ada/s-osinte-hpux.ads
View File

@ -387,9 +387,9 @@ package System.OS_Interface is
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
----------------------------
-- POSIX.1c Section 13 --
----------------------------
--------------------------
-- POSIX.1c Section 13 --
--------------------------
PTHREAD_PRIO_NONE : constant := 16#100#;
PTHREAD_PRIO_PROTECT : constant := 16#200#;
@ -436,9 +436,9 @@ package System.OS_Interface is
function sched_yield return int;
pragma Import (C, sched_yield, "sched_yield");
---------------------------
-- P1003.1c - Section 16 --
---------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init
(attributes : access pthread_attr_t) return int;

11
gcc/ada/s-osinte-irix.ads
View File

@ -452,11 +452,12 @@ package System.OS_Interface is
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "pthread_key_create");
---------------------------------------------------------------
-- Non portable SGI 6.5 additions to the pthread interface --
-- must be executed from within the context of a system --
-- scope task --
---------------------------------------------------------------
-------------------
-- SGI Additions --
-------------------
-- Non portable SGI 6.5 additions to the pthread interface must be
-- executed from within the context of a system scope task.
function pthread_setrunon_np (cpu : int) return int;
pragma Import (C, pthread_setrunon_np, "pthread_setrunon_np");

18
gcc/ada/s-osinte-lynxos.ads
View File

@ -310,16 +310,16 @@ package System.OS_Interface is
function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
-----------------------------------------
-- Nonstandard Thread Initialization --
-----------------------------------------
---------------------------------------
-- Nonstandard Thread Initialization --
---------------------------------------
procedure pthread_init;
-- This is a dummy procedure to share some GNULLI files
---------------------------
-- POSIX.1c Section 3 --
---------------------------
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function sigwait
(set : access sigset_t;
@ -447,9 +447,9 @@ package System.OS_Interface is
function sched_yield return int;
pragma Import (C, sched_yield, "sched_yield");
---------------------------
-- P1003.1c - Section 16 --
---------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "pthread_attr_init");

24
gcc/ada/s-osinte-tru64.ads
View File

@ -285,9 +285,9 @@ package System.OS_Interface is
pragma Inline (pthread_init);
-- This is a dummy procedure to share some GNULLI files
---------------------------
-- POSIX.1c Section 3 --
---------------------------
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function sigwait
(set : access sigset_t;
@ -307,9 +307,9 @@ package System.OS_Interface is
oset : sigset_t_ptr) return int;
pragma Import (C, pthread_sigmask);
----------------------------
-- POSIX.1c Section 11 --
----------------------------
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init (attr : access pthread_mutexattr_t)
return int;
@ -363,9 +363,9 @@ package System.OS_Interface is
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait");
----------------------------
-- POSIX.1c Section 13 --
----------------------------
--------------------------
-- POSIX.1c Section 13 --
--------------------------
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t;
@ -410,9 +410,9 @@ package System.OS_Interface is
function sched_yield return int;
pragma Import (C, sched_yield);
---------------------------
-- P1003.1c - Section 16 --
---------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t)
return int;

18
gcc/ada/s-osinte-vms.ads
View File

@ -407,9 +407,9 @@ package System.OS_Interface is
(newtype : int; oldtype : access int) return int;
pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
---------------------------
-- POSIX.1c Section 3 --
---------------------------
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function pthread_lock_global_np return int;
pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
@ -417,9 +417,9 @@ package System.OS_Interface is
function pthread_unlock_global_np return int;
pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
----------------------------
-- POSIX.1c Section 11 --
----------------------------
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
@ -522,9 +522,9 @@ package System.OS_Interface is
function sched_yield return int;
-----------------------------
-- P1003.1c - Section 16 --
-----------------------------
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT");

8
gcc/ada/s-osinte-vxworks.ads
View File

@ -197,13 +197,13 @@ package System.OS_Interface is
function tickGet return ULONG;
pragma Import (C, tickGet, "tickGet");
-----------------------------------------------------
-- Convenience routine to convert between VxWorks --
-- priority and Ada priority. --
-----------------------------------------------------
----------------------
-- Utility Routines --
----------------------
function To_VxWorks_Priority (Priority : in int) return int;
pragma Inline (To_VxWorks_Priority);
-- Convenience routine to convert between VxWorks priority and Ada priority
--------------------------
-- VxWorks specific API --

8
gcc/ada/s-osprim-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -47,9 +47,9 @@ package body System.OS_Primitives is
use System.OS_Interface;
use type Interfaces.C.int;
--------------------------
-- Internal functions --
--------------------------
------------------------
-- Internal functions --
------------------------
function To_Clock_Ticks (D : Duration) return int;
-- Convert a duration value (in seconds) into clock ticks.

597
gcc/ada/s-taprop-dummy.adb
View File

@ -55,275 +55,8 @@ package body System.Task_Primitives.Operations is
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
-----------------
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
begin
null;
end Stack_Guard;
--------------------
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return OSI.Thread_Id (T.Common.LL.Thread);
end Get_Thread_Id;
----------
-- Self --
----------
function Self return Task_Id is
begin
return Null_Task;
end Self;
---------------------
-- Initialize_Lock --
---------------------
procedure Initialize_Lock
(Prio : System.Any_Priority;
L : access Lock)
is
begin
null;
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
begin
null;
end Initialize_Lock;
-------------------
-- Finalize_Lock --
-------------------
procedure Finalize_Lock (L : access Lock) is
begin
null;
end Finalize_Lock;
procedure Finalize_Lock (L : access RTS_Lock) is
begin
null;
end Finalize_Lock;
----------------
-- Write_Lock --
----------------
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
Ceiling_Violation := False;
end Write_Lock;
procedure Write_Lock
(L : access RTS_Lock;
Global_Lock : Boolean := False)
is
begin
null;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
null;
end Write_Lock;
---------------
-- Read_Lock --
---------------
procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
Ceiling_Violation := False;
end Read_Lock;
------------
-- Unlock --
------------
procedure Unlock (L : access Lock) is
begin
null;
end Unlock;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
begin
null;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
null;
end Unlock;
-----------
-- Sleep --
-----------
procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Sleep;
-----------------
-- Timed_Sleep --
-----------------
procedure Timed_Sleep
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
Timedout : out Boolean;
Yielded : out Boolean) is
begin
Timedout := False;
Yielded := False;
end Timed_Sleep;
-----------------
-- Timed_Delay --
-----------------
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes) is
begin
null;
end Timed_Delay;
---------------------
-- Monotonic_Clock --
---------------------
function Monotonic_Clock return Duration is
begin
return 0.0;
end Monotonic_Clock;
-------------------
-- RT_Resolution --
-------------------
function RT_Resolution return Duration is
begin
return 10#1.0#E-6;
end RT_Resolution;
------------
-- Wakeup --
------------
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Wakeup;
------------------
-- Set_Priority --
------------------
procedure Set_Priority
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False) is
begin
null;
end Set_Priority;
------------------
-- Get_Priority --
------------------
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return 0;
end Get_Priority;
----------------
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_Id) is
begin
null;
end Enter_Task;
--------------
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
-------------------
-- Is_Valid_Task --
-------------------
function Is_Valid_Task return Boolean is
begin
return False;
end Is_Valid_Task;
-----------------------------
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
----------------------
-- Initialize_TCB --
----------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Succeeded := False;
end Initialize_TCB;
-----------------
-- Create_Task --
-----------------
procedure Create_Task
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
Succeeded : out Boolean) is
begin
Succeeded := False;
end Create_Task;
------------------
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_Id) is
begin
null;
end Finalize_TCB;
---------------
-- Exit_Task --
---------------
procedure Exit_Task is
begin
null;
end Exit_Task;
No_Tasking : Boolean;
-- Comment required here ???
----------------
-- Abort_Task --
@ -334,21 +67,11 @@ package body System.Task_Primitives.Operations is
null;
end Abort_Task;
-----------
-- Yield --
-----------
procedure Yield (Do_Yield : Boolean := True) is
begin
null;
end Yield;
----------------
-- Check_Exit --
----------------
-- Dummy versions. The only currently working versions is for solaris
-- (native).
-- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
@ -373,6 +96,124 @@ package body System.Task_Primitives.Operations is
return null;
end Environment_Task;
-----------------
-- Create_Task --
-----------------
procedure Create_Task
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
begin
Succeeded := False;
end Create_Task;
----------------
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_Id) is
begin
null;
end Enter_Task;
---------------
-- Exit_Task --
---------------
procedure Exit_Task is
begin
null;
end Exit_Task;
-------------------
-- Finalize_Lock --
-------------------
procedure Finalize_Lock (L : access Lock) is
begin
null;
end Finalize_Lock;
procedure Finalize_Lock (L : access RTS_Lock) is
begin
null;
end Finalize_Lock;
------------------
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_Id) is
begin
null;
end Finalize_TCB;
------------------
-- Get_Priority --
------------------
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return 0;
end Get_Priority;
--------------------
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return OSI.Thread_Id (T.Common.LL.Thread);
end Get_Thread_Id;
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_Id) is
begin
null;
end Initialize;
---------------------
-- Initialize_Lock --
---------------------
procedure Initialize_Lock
(Prio : System.Any_Priority;
L : access Lock)
is
begin
null;
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
begin
null;
end Initialize_Lock;
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Succeeded := False;
end Initialize_TCB;
-------------------
-- Is_Valid_Task --
-------------------
function Is_Valid_Task return Boolean is
begin
return False;
end Is_Valid_Task;
--------------
-- Lock_RTS --
--------------
@ -382,14 +223,102 @@ package body System.Task_Primitives.Operations is
null;
end Lock_RTS;
----------------
-- Unlock_RTS --
----------------
---------------------
-- Monotonic_Clock --
---------------------
procedure Unlock_RTS is
function Monotonic_Clock return Duration is
begin
return 0.0;
end Monotonic_Clock;
--------------
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
---------------
-- Read_Lock --
---------------
procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
Ceiling_Violation := False;
end Read_Lock;
-----------------------------
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
-----------------
-- Resume_Task --
-----------------
function Resume_Task
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id) return Boolean
is
begin
return False;
end Resume_Task;
-------------------
-- RT_Resolution --
-------------------
function RT_Resolution return Duration is
begin
return 10#1.0#E-6;
end RT_Resolution;
----------
-- Self --
----------
function Self return Task_Id is
begin
return Null_Task;
end Self;
------------------
-- Set_Priority --
------------------
procedure Set_Priority
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
begin
null;
end Unlock_RTS;
end Set_Priority;
-----------
-- Sleep --
-----------
procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Sleep;
-----------------
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
begin
null;
end Stack_Guard;
------------------
-- Suspend_Task --
@ -404,27 +333,101 @@ package body System.Task_Primitives.Operations is
end Suspend_Task;
-----------------
-- Resume_Task --
-- Timed_Delay --
-----------------
function Resume_Task
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id) return Boolean
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
begin
return False;
end Resume_Task;
null;
end Timed_Delay;
----------------
-- Initialize --
----------------
-----------------
-- Timed_Sleep --
-----------------
procedure Initialize (Environment_Task : Task_Id) is
procedure Timed_Sleep
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
Timedout : out Boolean;
Yielded : out Boolean)
is
begin
Timedout := False;
Yielded := False;
end Timed_Sleep;
------------
-- Unlock --
------------
procedure Unlock (L : access Lock) is
begin
null;
end Initialize;
end Unlock;
No_Tasking : Boolean;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
begin
null;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
null;
end Unlock;
----------------
-- Unlock_RTS --
----------------
procedure Unlock_RTS is
begin
null;
end Unlock_RTS;
------------
-- Wakeup --
------------
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Wakeup;
----------------
-- Write_Lock --
----------------
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
Ceiling_Violation := False;
end Write_Lock;
procedure Write_Lock
(L : access RTS_Lock;
Global_Lock : Boolean := False)
is
begin
null;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
null;
end Write_Lock;
-----------
-- Yield --
-----------
procedure Yield (Do_Yield : Boolean := True) is
begin
null;
end Yield;
begin
-- Can't raise an exception because target independent packages try to

49
gcc/ada/s-taprop-hpux-dce.adb
View File

@ -73,7 +73,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -93,9 +93,9 @@ package body System.Task_Primitives.Operations is
package PIO renames System.Task_Primitives.Interrupt_Operations;
package SSL renames System.Soft_Links;
------------------
-- Local Data --
------------------
----------------
-- Local Data --
----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
@ -109,7 +109,7 @@ package body System.Task_Primitives.Operations is
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- A variable to hold Task_Id for the environment task
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
@ -125,10 +125,10 @@ package body System.Task_Primitives.Operations is
-- stage considered dead, and no further work is planned on it.
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
-- Indicates whether FIFO_Within_Priorities is set
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
-- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
@ -138,7 +138,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
-- Initialize various data needed by this package
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
@ -146,23 +146,23 @@ package body System.Task_Primitives.Operations is
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
-- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
-- Return a pointer to the Ada Task Control Block of the calling task
end Specific;
package body Specific is separate;
-- The body of this package is target specific.
-- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
-- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
@ -339,7 +339,6 @@ package body System.Task_Primitives.Operations is
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@ -349,7 +348,6 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@ -372,7 +370,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
@ -389,7 +386,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@ -417,7 +413,8 @@ package body System.Task_Primitives.Operations is
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure.
-- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
@ -498,9 +495,8 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
-- The little window between deferring abort and locking Self_ID is the
-- only reason to check for pending abort and priority change below!
SSL.Abort_Defer.all;
@ -564,7 +560,6 @@ package body System.Task_Primitives.Operations is
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
begin
Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
@ -918,8 +913,7 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
-- Dummy versions. The only currently working versions is for solaris
-- (native).
-- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
@ -974,7 +968,6 @@ package body System.Task_Primitives.Operations is
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
begin
return False;
end Suspend_Task;
@ -989,7 +982,6 @@ package body System.Task_Primitives.Operations is
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
begin
return False;
end Resume_Task;
@ -1007,9 +999,8 @@ package body System.Task_Primitives.Operations is
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
-- Get interrupt state. Defined in a-init.c. The input argument is
-- the interrupt number, and the result is one of the following:
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
@ -1021,7 +1012,7 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);

17
gcc/ada/s-taprop-irix-athread.adb
View File

@ -74,7 +74,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -129,9 +129,9 @@ package body System.Task_Primitives.Operations is
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Stack_Guard --
-------------------
-----------------
-- Stack_Guard --
-----------------
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
@ -566,7 +566,6 @@ package body System.Task_Primitives.Operations is
T.Common.Current_Priority := Prio;
Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
pragma Assert (Result /= FUNC_ERR);
end Set_Priority;
------------------
@ -634,9 +633,9 @@ package body System.Task_Primitives.Operations is
return null;
end Register_Foreign_Thread;
----------------------
-- Initialize_TCB --
----------------------
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
@ -942,7 +941,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result /= FUNC_ERR);
if Result = FUNC_ERR then
raise Storage_Error; -- Insufficient resources.
raise Storage_Error; -- Insufficient resources
end if;
end Initialize_Athread_Library;

43
gcc/ada/s-taprop-irix.adb
View File

@ -75,7 +75,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.Program_Info;
-- used for Default_Task_Stack
@ -104,9 +104,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
------------------
-- Local Data --
------------------
----------------
-- Local Data --
----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
@ -120,7 +120,7 @@ package body System.Task_Primitives.Operations is
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- A variable to hold Task_Id for the environment task
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@ -130,7 +130,7 @@ package body System.Task_Primitives.Operations is
Unblocked_Signal_Mask : aliased sigset_t;
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
-- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
@ -140,7 +140,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
-- Initialize various data needed by this package
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
@ -148,23 +148,23 @@ package body System.Task_Primitives.Operations is
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
-- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
-- Return a pointer to the Ada Task Control Block of the calling task
end Specific;
package body Specific is separate;
-- The body of this package is target specific.
-- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
-- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
@ -176,7 +176,7 @@ package body System.Task_Primitives.Operations is
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
procedure Abort_Handler (Sig : Signal);
-- Signal handler used to implement asynchronous abort.
-- Signal handler used to implement asynchronous abort
-------------------
-- Abort_Handler --
@ -440,7 +440,7 @@ package body System.Task_Primitives.Operations is
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure.
-- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
@ -506,9 +506,8 @@ package body System.Task_Primitives.Operations is
-- Timed_Delay --
-----------------
-- This is for use in implementing delay statements, so
-- we assume the caller is abort-deferred but is holding
-- no locks.
-- This is for use in implementing delay statements, so we assume
-- the caller is abort-deferred but is holding no locks.
procedure Timed_Delay
(Self_ID : Task_Id;
@ -521,9 +520,9 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
-- check for pending abort and priority change below! :(
-- The little window between deferring abort and locking Self_ID is
-- the only reason we need to check for pending abort and priority
-- change below!
SSL.Abort_Defer.all;
@ -598,10 +597,11 @@ package body System.Task_Primitives.Operations is
-- resolution of reading the clock. Even though this last value is
-- only guaranteed to be 100 Hz, at least the Origin 200 appears to
-- have a microsecond resolution or better.
-- ??? We should figure out a method to return the right value on
-- all SGI hardware.
return 0.000_001; -- Assume microsecond resolution of clock
return 0.000_001;
end RT_Resolution;
------------
@ -1121,8 +1121,9 @@ begin
end loop;
-- Pick the highest resolution Clock for Clock_Realtime
-- ??? This code currently doesn't work (see c94007[ab] for example)
--
-- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then
-- Real_Time_Clock_Id := CLOCK_SGI_CYCLE;
-- else

39
gcc/ada/s-taprop-linux.adb
View File

@ -75,7 +75,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -97,9 +97,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
------------------
-- Local Data --
------------------
----------------
-- Local Data --
----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
@ -113,18 +113,18 @@ package body System.Task_Primitives.Operations is
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- A variable to hold Task_Id for the environment task
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
-- The followings are internal configuration constants needed.
-- The followings are internal configuration constants needed
Priority_Ceiling_Emulation : constant Boolean := True;
Next_Serial_Number : Task_Serial_Number := 100;
-- We start at 100, to reserve some special values for
-- using in error checking.
-- The following are internal configuration constants needed.
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@ -133,7 +133,7 @@ package body System.Task_Primitives.Operations is
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
-- Indicates whether FIFO_Within_Priorities is set
-- The following are effectively constants, but they need to
-- be initialized by calling a pthread_ function.
@ -142,7 +142,7 @@ package body System.Task_Primitives.Operations is
Cond_Attr : aliased pthread_condattr_t;
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
-- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
@ -152,7 +152,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
-- Initialize various data needed by this package
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
@ -160,7 +160,7 @@ package body System.Task_Primitives.Operations is
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
-- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
@ -169,14 +169,14 @@ package body System.Task_Primitives.Operations is
end Specific;
package body Specific is separate;
-- The body of this package is target specific.
-- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
-- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
@ -323,7 +323,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_destroy (L.L'Access);
pragma Assert (Result = 0);
@ -331,7 +330,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@ -381,7 +379,6 @@ package body System.Task_Primitives.Operations is
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@ -391,7 +388,6 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@ -437,7 +433,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@ -447,7 +442,6 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@ -478,7 +472,8 @@ package body System.Task_Primitives.Operations is
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure.
-- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
@ -631,7 +626,6 @@ package body System.Task_Primitives.Operations is
function Monotonic_Clock return Duration is
TV : aliased struct_timeval;
Result : Interfaces.C.int;
begin
Result := gettimeofday (TV'Access, System.Null_Address);
pragma Assert (Result = 0);
@ -785,7 +779,7 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
-- Give the task a unique serial number.
-- Give the task a unique serial number
Self_ID.Serial_Number := Next_Serial_Number;
Next_Serial_Number := Next_Serial_Number + 1;
@ -932,7 +926,6 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));

16
gcc/ada/s-taprop-lynxos.adb
View File

@ -74,7 +74,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -821,9 +821,9 @@ package body System.Task_Primitives.Operations is
end if;
end Register_Foreign_Thread;
----------------------
-- Initialize_TCB --
----------------------
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
@ -831,7 +831,7 @@ package body System.Task_Primitives.Operations is
Cond_Attr : aliased pthread_condattr_t;
begin
-- Give the task a unique serial number.
-- Give the task a unique serial number
Self_ID.Serial_Number := Next_Serial_Number;
Next_Serial_Number := Next_Serial_Number + 1;
@ -1016,8 +1016,10 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
Result :=
pthread_kill
(T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;

2
gcc/ada/s-taprop-mingw.adb
View File

@ -67,7 +67,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes

2
gcc/ada/s-taprop-os2.adb
View File

@ -68,7 +68,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes

2
gcc/ada/s-taprop-posix.adb
View File

@ -79,7 +79,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes

16
gcc/ada/s-taprop-solaris.adb
View File

@ -81,7 +81,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -311,9 +311,9 @@ package body System.Task_Primitives.Operations is
end if;
end Abort_Handler;
-------------------
-- Stack_Guard --
-------------------
-----------------
-- Stack_Guard --
-----------------
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
@ -325,9 +325,9 @@ package body System.Task_Primitives.Operations is
null;
end Stack_Guard;
--------------------
-- Get_Thread_Id --
--------------------
-------------------
-- Get_Thread_Id --
-------------------
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
@ -506,7 +506,7 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock
(L : access RTS_Lock;
(L : access RTS_Lock;
Level : Lock_Level)
is
Result : Interfaces.C.int;

2
gcc/ada/s-taprop-tru64.adb
View File

@ -77,7 +77,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes

14
gcc/ada/s-taprop-vms.adb
View File

@ -61,7 +61,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Primitives;
-- used for Delay_Modes
@ -81,9 +81,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
------------------
-- Local Data --
------------------
----------------
-- Local Data --
----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
@ -706,9 +706,9 @@ package body System.Task_Primitives.Operations is
end if;
end Register_Foreign_Thread;
----------------------
-- Initialize_TCB --
----------------------
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;

2
gcc/ada/s-taprop-vxworks.adb
View File

@ -55,7 +55,7 @@ with System.Soft_Links;
-- Note that we do not use System.Tasking.Initialization directly since
-- this is a higher level package that we shouldn't depend on. For example
-- when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Initialization
-- System.Tasking.Restricted.Stages.
with System.OS_Interface;
-- used for various type, constant, and operations

6
gcc/ada/s-tarest.adb
View File

@ -120,9 +120,9 @@ package body System.Tasking.Restricted.Stages is
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
------------------------
-- Local Subprograms --
------------------------
-----------------------
-- Local Subprograms --
-----------------------
procedure Task_Wrapper (Self_ID : Task_Id);
-- This is the procedure that is called by the GNULL from the

10
gcc/ada/s-tasini.ads
View File

@ -106,7 +106,7 @@ package System.Tasking.Initialization is
-- For the sake of efficiency, the version with Self_ID as parameter
-- should used wherever possible. These are all nestable.
-- Non-nestable inline versions --
-- Non-nestable inline versions
procedure Defer_Abort (Self_ID : Task_Id);
pragma Inline (Defer_Abort);
@ -114,7 +114,7 @@ package System.Tasking.Initialization is
procedure Undefer_Abort (Self_ID : Task_Id);
pragma Inline (Undefer_Abort);
-- Nestable inline versions --
-- Nestable inline versions
procedure Defer_Abort_Nestable (Self_ID : Task_Id);
pragma Inline (Defer_Abort_Nestable);
@ -135,9 +135,9 @@ package System.Tasking.Initialization is
-- Returns Boolean'Pos (True) iff abort signal should raise
-- Standard.Abort_Signal. Only used by IRIX currently.
---------------------------
-- Change Base Priority --
---------------------------
--------------------------
-- Change Base Priority --
--------------------------
procedure Change_Base_Priority (T : Task_Id);
-- Change the base priority of T.

55
gcc/ada/s-taskin.ads
View File

@ -55,21 +55,21 @@ with Unchecked_Conversion;
package System.Tasking is
-- -------------------
-- -- Locking Rules --
-- -------------------
--
-------------------
-- Locking Rules --
-------------------
-- The following rules must be followed at all times, to prevent
-- deadlock and generally ensure correct operation of locking.
--
-- . Never lock a lock unless abort is deferred.
--
-- . Never undefer abort while holding a lock.
--
-- . Overlapping critical sections must be properly nested,
-- and locks must be released in LIFO order.
-- e.g., the following is not allowed:
--
-- Lock (X);
-- ...
-- Lock (Y);
@ -77,31 +77,31 @@ package System.Tasking is
-- Unlock (X);
-- ...
-- Unlock (Y);
--
-- Locks with lower (smaller) level number cannot be locked
-- while holding a lock with a higher level number. (The level
-- number is the number at the left.)
--
-- 1. System.Tasking.PO_Simple.Protection.L (any PO lock)
-- 2. System.Tasking.Initialization.Global_Task_Lock (in body)
-- 3. System.Task_Primitives.Operations.Single_RTS_Lock
-- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock)
--
-- Clearly, there can be no circular chain of hold-and-wait
-- relationships involving locks in different ordering levels.
--
-- We used to have Global_Task_Lock before Protection.L but this was
-- clearly wrong since there can be calls to "new" inside protected
-- operations. The new ordering prevents these failures.
--
-- Sometimes we need to hold two ATCB locks at the same time. To allow
-- us to order the locking, each ATCB is given a unique serial
-- number. If one needs to hold locks on several ATCBs at once,
-- the locks with lower serial numbers must be locked first.
--
-- We don't always need to check the serial numbers, since
-- the serial numbers are assigned sequentially, and so:
--
-- . The parent of a task always has a lower serial number.
-- . The activator of a task always has a lower serial number.
-- . The environment task has a lower serial number than any other task.
@ -360,25 +360,24 @@ package System.Tasking is
-- Some protection is described in terms of tasks related to the
-- ATCB being protected. These are:
-- Self: The task which is controlled by this ATCB.
-- Acceptor: A task accepting a call from Self.
-- Caller: A task calling an entry of Self.
-- Parent: The task executing the master on which Self depends.
-- Dependent: A task dependent on Self.
-- Activator: The task that created Self and initiated its activation.
-- Created: A task created and activated by Self.
-- Self: The task which is controlled by this ATCB
-- Acceptor: A task accepting a call from Self
-- Caller: A task calling an entry of Self
-- Parent: The task executing the master on which Self depends
-- Dependent: A task dependent on Self
-- Activator: The task that created Self and initiated its activation
-- Created: A task created and activated by Self
-- Note: The order of the fields is important to implement efficiently
-- tasking support under gdb.
-- Currently gdb relies on the order of the State, Parent, Base_Priority,
-- Task_Image, Task_Image_Len, Call and LL fields.
----------------------------------------------------------------------
-- Common ATCB section --
-- --
-- This section is used by all GNARL implementations (regular and --
-- restricted) --
----------------------------------------------------------------------
-------------------------
-- Common ATCB section --
-------------------------
-- Section used by all GNARL implementations (regular and restricted)
type Common_ATCB is record
State : Task_States;

6
gcc/ada/scng.adb
View File

@ -443,9 +443,9 @@ package body Scng is
Error_Msg_S ("digit expected");
end Error_Digit_Expected;
-------------------
-- Scan_Integer --
-------------------
------------------
-- Scan_Integer --
------------------
procedure Scan_Integer is
C : Character;

30
gcc/ada/sem_attr.adb
View File

@ -250,7 +250,8 @@ package body Sem_Attr is
-- two attribute expressions are present
procedure Legal_Formal_Attribute;
-- Common processing for attributes Definite, and Has_Discriminants
-- Common processing for attributes Definite, Has_Access_Values,
-- and Has_Discriminants
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
@ -2602,6 +2603,15 @@ package body Sem_Attr is
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
-----------------------
-- Has_Access_Values --
-----------------------
when Attribute_Has_Access_Values =>
Check_Type;
Check_E0;
Set_Etype (N, Standard_Boolean);
-----------------------
-- Has_Discriminants --
-----------------------
@ -4434,6 +4444,8 @@ package body Sem_Attr is
elsif (Id = Attribute_Definite
or else
Id = Attribute_Has_Access_Values
or else
Id = Attribute_Has_Discriminants
or else
Id = Attribute_Type_Class
@ -4541,11 +4553,14 @@ package body Sem_Attr is
-- In addition Component_Size is possibly foldable, even though it
-- can never be static.
-- Definite, Has_Discriminants, Type_Class and Unconstrained_Array are
-- again exceptions, because they apply as well to unconstrained types.
-- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and
-- Unconstrained_Array are again exceptions, because they apply as
-- well to unconstrained types.
elsif Id = Attribute_Definite
or else
Id = Attribute_Has_Access_Values
or else
Id = Attribute_Has_Discriminants
or else
Id = Attribute_Type_Class
@ -4947,6 +4962,15 @@ package body Sem_Attr is
Fold_Ureal (N,
Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
-----------------------
-- Has_Access_Values --
-----------------------
when Attribute_Has_Access_Values =>
Rewrite (N, New_Occurrence_Of
(Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
-----------------------
-- Has_Discriminants --
-----------------------

6
gcc/ada/sem_cat.adb
View File

@ -1088,9 +1088,9 @@ package body Sem_Cat is
end Validate_Object_Declaration;
--------------------------------
-- Validate_RCI_Declarations --
--------------------------------
-------------------------------
-- Validate_RCI_Declarations --
-------------------------------
procedure Validate_RCI_Declarations (P : Entity_Id) is
E : Entity_Id;

12
gcc/ada/sem_ch10.adb
View File

@ -1311,9 +1311,9 @@ package body Sem_Ch10 is
-- Remove current scope from scope stack, and preserve the list
-- of use clauses in it, to be reinstalled after context is analyzed.
------------------------------
-- Analyze_Subunit_Context --
------------------------------
-----------------------------
-- Analyze_Subunit_Context --
-----------------------------
procedure Analyze_Subunit_Context is
Item : Node_Id;
@ -2868,9 +2868,9 @@ package body Sem_Ch10 is
-- context_clause as a nonlimited with_clause that mentions
-- the same library.
--------------------
-- Check_Parent --
--------------------
------------------
-- Check_Parent --
------------------
procedure Check_Parent (P : Node_Id; W : Node_Id) is
Item : Node_Id;

18
gcc/ada/sem_ch12.adb
View File

@ -2549,6 +2549,12 @@ package body Sem_Ch12 is
if Unit_Requires_Body (Scop) then
Enclosing_Body_Present := True;
exit;
elsif In_Open_Scopes (Scop)
and then In_Package_Body (Scop)
then
Enclosing_Body_Present := True;
exit;
end if;
exit when Is_Compilation_Unit (Scop);
@ -2847,9 +2853,9 @@ package body Sem_Ch12 is
end if;
end Analyze_Package_Instantiation;
---------------------------
-- Inline_Instance_Body --
---------------------------
--------------------------
-- Inline_Instance_Body --
--------------------------
procedure Inline_Instance_Body
(N : Node_Id;
@ -4583,9 +4589,9 @@ package body Sem_Ch12 is
-- (for ASIS use) even though as the name of an enclosing generic
-- it would otherwise not be preserved in the generic tree.
-----------------------
-- Copy_Descendants --
-----------------------
----------------------
-- Copy_Descendants --
----------------------
procedure Copy_Descendants is

4
gcc/ada/sem_ch13.adb
View File

@ -1110,8 +1110,10 @@ package body Sem_Ch13 is
and then
Size /= System_Storage_Unit * 8
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_N
("size for primitive object must be power of 2", N);
("size for primitive object must be a power of 2"
& " and at least ^", N);
end if;
end if;

2
gcc/ada/sem_ch13.ads
View File

@ -47,7 +47,7 @@ package Sem_Ch13 is
function Minimum_Size
(T : Entity_Id;
Biased : Boolean := False) return Nat;
-- Given a primitive type, determines the minimum number of bits required
-- Given an elementary type, determines the minimum number of bits required
-- to represent all values of the type. This function may not be called
-- with any other types. If the flag Biased is set True, then the minimum
-- size calculation that biased representation is used in the case of a

12
gcc/ada/sem_ch4.adb
View File

@ -1847,9 +1847,9 @@ package body Sem_Ch4 is
Operator_Check (N);
end Analyze_Negation;
-------------------
-- Analyze_Null --
-------------------
------------------
-- Analyze_Null --
------------------
procedure Analyze_Null (N : Node_Id) is
begin
@ -2134,9 +2134,9 @@ package body Sem_Ch4 is
end if;
end Analyze_One_Call;
----------------------------
-- Analyze_Operator_Call --
----------------------------
---------------------------
-- Analyze_Operator_Call --
---------------------------
procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
Op_Name : constant Name_Id := Chars (Op_Id);

6
gcc/ada/sem_ch6.adb
View File

@ -4480,6 +4480,12 @@ package body Sem_Ch6 is
if not Comes_From_Source (S) then
null;
-- If the subprogram is at library level, it is not a
-- primitive operation.
elsif Current_Scope = Standard_Standard then
null;
elsif (Ekind (Current_Scope) = E_Package
and then not In_Package_Body (Current_Scope))
or else Overriding

16
gcc/ada/sem_ch7.adb
View File

@ -799,9 +799,9 @@ package body Sem_Ch7 is
end if;
end Is_Public_Child;
--------------------------------------------
-- Inspect_Deferred_Constant_Completion --
--------------------------------------------
------------------------------------------
-- Inspect_Deferred_Constant_Completion --
------------------------------------------
procedure Inspect_Deferred_Constant_Completion is
Decl : Node_Id;
@ -1935,7 +1935,7 @@ package body Sem_Ch7 is
end;
end if;
-- Otherwise search entity chain for entity requiring completion.
-- Otherwise search entity chain for entity requiring completion
E := First_Entity (P);
while Present (E) loop
@ -1947,6 +1947,14 @@ package body Sem_Ch7 is
if Is_Child_Unit (E) then
null;
-- Ignore formal packages and their renamings
elsif Ekind (E) = E_Package
and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
N_Formal_Package_Declaration
then
null;
-- Otherwise test to see if entity requires a completion
elsif (Is_Overloadable (E)

24
gcc/ada/sem_ch8.adb
View File

@ -549,18 +549,18 @@ package body Sem_Ch8 is
end if;
end Analyze_Expanded_Name;
----------------------------------------
-- Analyze_Generic_Function_Renaming --
----------------------------------------
---------------------------------------
-- Analyze_Generic_Function_Renaming --
---------------------------------------
procedure Analyze_Generic_Function_Renaming (N : Node_Id) is
begin
Analyze_Generic_Renaming (N, E_Generic_Function);
end Analyze_Generic_Function_Renaming;
---------------------------------------
-- Analyze_Generic_Package_Renaming --
---------------------------------------
--------------------------------------
-- Analyze_Generic_Package_Renaming --
--------------------------------------
procedure Analyze_Generic_Package_Renaming (N : Node_Id) is
begin
@ -572,9 +572,9 @@ package body Sem_Ch8 is
Analyze_Generic_Renaming (N, E_Generic_Package);
end Analyze_Generic_Package_Renaming;
-----------------------------------------
-- Analyze_Generic_Procedure_Renaming --
-----------------------------------------
----------------------------------------
-- Analyze_Generic_Procedure_Renaming --
----------------------------------------
procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is
begin
@ -1941,9 +1941,9 @@ package body Sem_Ch8 is
Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
end Chain_Use_Clause;
----------------------------
-- Check_Frozen_Renaming --
----------------------------
---------------------------
-- Check_Frozen_Renaming --
---------------------------
procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
B_Node : Node_Id;

13
gcc/ada/sem_disp.adb
View File

@ -66,21 +66,19 @@ package body Sem_Disp is
function Check_Controlling_Type
(T : Entity_Id;
Subp : Entity_Id)
return Entity_Id;
Subp : Entity_Id) return Entity_Id;
-- T is the type of a formal parameter of subp. Returns the tagged
-- if the parameter can be a controlling argument, empty otherwise
--------------------------------
-- Add_Dispatching_Operation --
--------------------------------
-------------------------------
-- Add_Dispatching_Operation --
-------------------------------
procedure Add_Dispatching_Operation
(Tagged_Type : Entity_Id;
New_Op : Entity_Id)
is
List : constant Elist_Id := Primitive_Operations (Tagged_Type);
begin
Append_Elmt (New_Op, List);
end Add_Dispatching_Operation;
@ -200,8 +198,7 @@ package body Sem_Disp is
function Check_Controlling_Type
(T : Entity_Id;
Subp : Entity_Id)
return Entity_Id
Subp : Entity_Id) return Entity_Id
is
Tagged_Type : Entity_Id := Empty;

6
gcc/ada/sem_prag.adb
View File

@ -5658,9 +5658,9 @@ package body Sem_Prag is
Source_Location);
end Eliminate;
--------------------------
-- Explicit_Overriding --
--------------------------
-------------------------
-- Explicit_Overriding --
-------------------------
when Pragma_Explicit_Overriding =>
Check_Valid_Configuration_Pragma;

6
gcc/ada/sem_res.adb
View File

@ -4974,9 +4974,9 @@ package body Sem_Res is
Eval_Integer_Literal (N);
end Resolve_Integer_Literal;
---------------------------------
-- Resolve_Intrinsic_Operator --
---------------------------------
--------------------------------
-- Resolve_Intrinsic_Operator --
--------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));

18
gcc/ada/sem_type.adb
View File

@ -59,14 +59,14 @@ package body Sem_Type is
-- of clash lists are stored in array Headers.
-- Headers Interp_Map All_Interp
--
-- _ ------- ----------
-- _ +-----+ +--------+
-- |_| |_____| --->|interp1 |
-- |_|---------->|node | | |interp2 |
-- |_| |index|---------| |nointerp|
-- |_| |next | | |
-- |-----| | |
-- ------- ----------
-- +-----+ +--------+
-- This scheme does not currently reclaim interpretations. In principle,
-- after a unit is compiled, all overloadings have been resolved, and the
@ -1559,9 +1559,9 @@ package body Sem_Type is
raise Program_Error;
end Get_First_Interp;
----------------------
-- Get_Next_Interp --
----------------------
---------------------
-- Get_Next_Interp --
---------------------
procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
begin
@ -2365,9 +2365,9 @@ package body Sem_Type is
end if;
end Write_Overloads;
-----------------------
-- Write_Interp_Ref --
-----------------------
----------------------
-- Write_Interp_Ref --
----------------------
procedure Write_Interp_Ref (Map_Ptr : Int) is
begin

8
gcc/ada/sem_type.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -72,9 +72,9 @@ package Sem_Type is
subtype Interp_Index is Int;
----------------------
-- Error Reporting --
----------------------
---------------------
-- Error Reporting --
---------------------
-- A common error is the use of an operator in infix notation on arguments
-- of a type that is not directly visible. Rather than diagnosing a type

139
gcc/ada/sem_util.adb
View File

@ -2656,12 +2656,17 @@ package body Sem_Util is
if Nkind (Decl) = N_Subprogram_Body then
return Decl;
-- The below comment is bad, because it is possible for
-- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
else -- Nkind (Decl) = N_Subprogram_Declaration
if Present (Corresponding_Body (Decl)) then
return Unit_Declaration_Node (Corresponding_Body (Decl));
else -- imported subprogram.
-- Imported subprogram case
else
return Empty;
end if;
end if;
@ -2676,6 +2681,55 @@ package body Sem_Util is
return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
end Get_Task_Body_Procedure;
-----------------------
-- Has_Access_Values --
-----------------------
function Has_Access_Values (T : Entity_Id) return Boolean is
Typ : constant Entity_Id := Underlying_Type (T);
begin
-- Case of a private type which is not completed yet. This can only
-- happen in the case of a generic format type appearing directly, or
-- as a component of the type to which this function is being applied
-- at the top level. Return False in this case, since we certainly do
-- not know that the type contains access types.
if No (Typ) then
return False;
elsif Is_Access_Type (Typ) then
return True;
elsif Is_Array_Type (Typ) then
return Has_Access_Values (Component_Type (Typ));
elsif Is_Record_Type (Typ) then
declare
Comp : Entity_Id;
begin
Comp := First_Entity (Typ);
while Present (Comp) loop
if (Ekind (Comp) = E_Component
or else
Ekind (Comp) = E_Discriminant)
and then Has_Access_Values (Etype (Comp))
then
return True;
end if;
Next_Entity (Comp);
end loop;
end;
return False;
else
return False;
end if;
end Has_Access_Values;
----------------------
-- Has_Declarations --
----------------------
@ -4654,9 +4708,9 @@ package body Sem_Util is
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
-- Clear current value for entity E and all entities chained to E
-------------------------------------------
-- Kill_Current_Values_For_Entity_Chain --
-------------------------------------------
------------------------------------------
-- Kill_Current_Values_For_Entity_Chain --
------------------------------------------
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
Ent : Entity_Id;
@ -4992,7 +5046,6 @@ package body Sem_Util is
end if;
Formal := First_Formal (S);
while Present (Formal) loop
-- Match the formals in order. If the corresponding actual
@ -5094,7 +5147,6 @@ package body Sem_Util is
Actual := First (Actuals);
while Present (Actual) loop
if Nkind (Actual) = N_Parameter_Association
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
@ -5669,11 +5721,13 @@ package body Sem_Util is
-- A transient scope is required when variable-sized temporaries are
-- allocated in the primary or secondary stack, or when finalization
-- actions must be generated before the next instruction
-- actions must be generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
Typ : constant Entity_Id := Underlying_Type (Id);
-- Start of processing for Requires_Transient_Scope
begin
-- This is a private type which is not completed yet. This can only
-- happen in a default expression (of a formal parameter or of a
@ -5682,23 +5736,22 @@ package body Sem_Util is
if No (Typ) then
return False;
-- Do not expand transient scope for non-existent procedure return
elsif Typ = Standard_Void_Type then
return False;
-- The back-end has trouble allocating variable-size temporaries so
-- we generate them in the front-end and need a transient scope to
-- reclaim them properly
-- Elementary types do not require a transient scope
elsif not Size_Known_At_Compile_Time (Typ) then
return True;
elsif Is_Elementary_Type (Typ) then
return False;
-- Unconstrained discriminated records always require a variable
-- length temporary, since the length may depend on the variant.
-- Generally, indefinite subtypes require a transient scope, since the
-- back end cannot generate temporaries, since this is not a valid type
-- for declaring an object. It might be possible to relax this in the
-- future, e.g. by declaring the maximum possible space for the type.
elsif Is_Record_Type (Typ)
and then Has_Discriminants (Typ)
and then not Is_Constrained (Typ)
then
elsif Is_Indefinite_Subtype (Typ) then
return True;
-- Functions returning tagged types may dispatch on result so their
@ -5710,13 +5763,53 @@ package body Sem_Util is
then
return True;
-- Unconstrained array types are returned on the secondary stack
-- Record type. OK if none of the component types requires a transient
-- scope. Note that we already know that this is a definite type (i.e.
-- has discriminant defaults if it is a discriminated record).
elsif Is_Record_Type (Typ) then
declare
Comp : Entity_Id;
begin
Comp := First_Entity (Typ);
while Present (Comp) loop
if Requires_Transient_Scope (Etype (Comp)) then
return True;
else
Next_Entity (Comp);
end if;
end loop;
end;
return False;
-- String literal types never require transient scope
elsif Ekind (Typ) = E_String_Literal_Subtype then
return False;
-- Array type. Note that we already know that this is a constrained
-- array, since unconstrained arrays will fail the indefinite test.
elsif Is_Array_Type (Typ) then
return not Is_Constrained (Typ);
end if;
return False;
-- If component type requires a transient scope, the array does too
if Requires_Transient_Scope (Component_Type (Typ)) then
return True;
-- Otherwise, we only need a transient scope if the size is not
-- known at compile time.
else
return not Size_Known_At_Compile_Time (Typ);
end if;
-- All other cases do not require a transient scope
else
return False;
end if;
end Requires_Transient_Scope;
--------------------------
@ -6573,7 +6666,7 @@ package body Sem_Util is
("found function name, possibly missing Access attribute!",
Expr);
-- catch common error: a prefix or infix operator which is not
-- Catch common error: a prefix or infix operator which is not
-- directly visible because the type isn't.
elsif Nkind (Expr) in N_Op

4
gcc/ada/sem_util.ads
View File

@ -357,6 +357,10 @@ package Sem_Util is
-- Task_Body_Procedure field from the corresponding task type
-- declaration.
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if type or subtype T is an access type, or has a
-- component (at any recursive level) that is an access type.
function Has_Declarations (N : Node_Id) return Boolean;
-- Determines if the node can have declarations

6
gcc/ada/sem_warn.adb
View File

@ -171,9 +171,9 @@ package body Sem_Warn is
-- from another unit. This is true for entities in packages that are
-- at the library level.
-----------------------
-- Missing_Subunits --
-----------------------
----------------------
-- Missing_Subunits --
----------------------
function Missing_Subunits return Boolean is
D : Node_Id;

6
gcc/ada/sinfo.ads
View File

@ -3065,9 +3065,9 @@ package Sinfo is
-- node (which appears as a singleton list). Box_Present gives support
-- to Ada 2005 (AI-287).
------------------------------------
-- 4.3.1 Commponent Choice List --
------------------------------------
-----------------------------------
-- 4.3.1 Commponent Choice List --
-----------------------------------
-- COMPONENT_CHOICE_LIST ::=
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}

6
gcc/ada/sinput-l.ads
View File

@ -34,9 +34,9 @@ with Types; use Types;
package Sinput.L is
-------------------------------------------
-- Subprograms for Loading Source Files --
-------------------------------------------
------------------------------------------
-- Subprograms for Loading Source Files --
------------------------------------------
function Load_Source_File (N : File_Name_Type) return Source_File_Index;
-- Given a source file name, returns the index of the corresponding entry

2
gcc/ada/snames.adb
View File

@ -145,6 +145,7 @@ package body Snames is
"target#" &
"req#" &
"obj_typecode#" &
"stub#" &
"Oabs#" &
"Oand#" &
"Omod#" &
@ -425,6 +426,7 @@ package body Snames is
"first_bit#" &
"fixed_value#" &
"fore#" &
"has_access_values#" &
"has_discriminants#" &
"identity#" &
"img#" &

1115
gcc/ada/snames.ads
View File

File diff suppressed because it is too large Load Diff

189
gcc/ada/snames.h
View File

@ -80,104 +80,105 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_First_Bit 32
#define Attr_Fixed_Value 33
#define Attr_Fore 34
#define Attr_Has_Discriminants 35
#define Attr_Identity 36
#define Attr_Img 37
#define Attr_Integer_Value 38
#define Attr_Large 39
#define Attr_Last 40
#define Attr_Last_Bit 41
#define Attr_Leading_Part 42
#define Attr_Length 43
#define Attr_Machine_Emax 44
#define Attr_Machine_Emin 45
#define Attr_Machine_Mantissa 46
#define Attr_Machine_Overflows 47
#define Attr_Machine_Radix 48
#define Attr_Machine_Rounds 49
#define Attr_Machine_Size 50
#define Attr_Mantissa 51
#define Attr_Max_Size_In_Storage_Elements 52
#define Attr_Maximum_Alignment 53
#define Attr_Mechanism_Code 54
#define Attr_Model_Emin 55
#define Attr_Model_Epsilon 56
#define Attr_Model_Mantissa 57
#define Attr_Model_Small 58
#define Attr_Modulus 59
#define Attr_Null_Parameter 60
#define Attr_Object_Size 61
#define Attr_Partition_ID 62
#define Attr_Passed_By_Reference 63
#define Attr_Pool_Address 64
#define Attr_Pos 65
#define Attr_Position 66
#define Attr_Range 67
#define Attr_Range_Length 68
#define Attr_Round 69
#define Attr_Safe_Emax 70
#define Attr_Safe_First 71
#define Attr_Safe_Large 72
#define Attr_Safe_Last 73
#define Attr_Safe_Small 74
#define Attr_Scale 75
#define Attr_Scaling 76
#define Attr_Signed_Zeros 77
#define Attr_Size 78
#define Attr_Small 79
#define Attr_Storage_Size 80
#define Attr_Storage_Unit 81
#define Attr_Tag 82
#define Attr_Target_Name 83
#define Attr_Terminated 84
#define Attr_To_Address 85
#define Attr_Type_Class 86
#define Attr_UET_Address 87
#define Attr_Unbiased_Rounding 88
#define Attr_Unchecked_Access 89
#define Attr_Unconstrained_Array 90
#define Attr_Universal_Literal_String 91
#define Attr_Unrestricted_Access 92
#define Attr_VADS_Size 93
#define Attr_Val 94
#define Attr_Valid 95
#define Attr_Value_Size 96
#define Attr_Version 97
#define Attr_Wide_Character_Size 98
#define Attr_Wide_Width 99
#define Attr_Width 100
#define Attr_Has_Access_Values 35
#define Attr_Has_Discriminants 36
#define Attr_Identity 37
#define Attr_Img 38
#define Attr_Integer_Value 39
#define Attr_Large 40
#define Attr_Last 41
#define Attr_Last_Bit 42
#define Attr_Leading_Part 43
#define Attr_Length 44
#define Attr_Machine_Emax 45
#define Attr_Machine_Emin 46
#define Attr_Machine_Mantissa 47
#define Attr_Machine_Overflows 48
#define Attr_Machine_Radix 49
#define Attr_Machine_Rounds 50
#define Attr_Machine_Size 51
#define Attr_Mantissa 52
#define Attr_Max_Size_In_Storage_Elements 53
#define Attr_Maximum_Alignment 54
#define Attr_Mechanism_Code 55
#define Attr_Model_Emin 56
#define Attr_Model_Epsilon 57
#define Attr_Model_Mantissa 58
#define Attr_Model_Small 59
#define Attr_Modulus 60
#define Attr_Null_Parameter 61
#define Attr_Object_Size 62
#define Attr_Partition_ID 63
#define Attr_Passed_By_Reference 64
#define Attr_Pool_Address 65
#define Attr_Pos 66
#define Attr_Position 67
#define Attr_Range 68
#define Attr_Range_Length 69
#define Attr_Round 70
#define Attr_Safe_Emax 71
#define Attr_Safe_First 72
#define Attr_Safe_Large 73
#define Attr_Safe_Last 74
#define Attr_Safe_Small 75
#define Attr_Scale 76
#define Attr_Scaling 77
#define Attr_Signed_Zeros 78
#define Attr_Size 79
#define Attr_Small 80
#define Attr_Storage_Size 81
#define Attr_Storage_Unit 82
#define Attr_Tag 83
#define Attr_Target_Name 84
#define Attr_Terminated 85
#define Attr_To_Address 86
#define Attr_Type_Class 87
#define Attr_UET_Address 88
#define Attr_Unbiased_Rounding 89
#define Attr_Unchecked_Access 90
#define Attr_Unconstrained_Array 91
#define Attr_Universal_Literal_String 92
#define Attr_Unrestricted_Access 93
#define Attr_VADS_Size 94
#define Attr_Val 95
#define Attr_Valid 96
#define Attr_Value_Size 97
#define Attr_Version 98
#define Attr_Wide_Character_Size 99
#define Attr_Wide_Width 100
#define Attr_Width 101
#define Attr_Word_Size 102
#define Attr_Word_Size 101
#define Attr_Adjacent 102
#define Attr_Ceiling 103
#define Attr_Copy_Sign 104
#define Attr_Floor 105
#define Attr_Fraction 106
#define Attr_Image 107
#define Attr_Input 108
#define Attr_Machine 109
#define Attr_Max 110
#define Attr_Min 111
#define Attr_Model 112
#define Attr_Pred 113
#define Attr_Remainder 114
#define Attr_Rounding 115
#define Attr_Succ 116
#define Attr_Truncation 117
#define Attr_Value 118
#define Attr_Wide_Image 119
#define Attr_Wide_Value 120
#define Attr_Adjacent 103
#define Attr_Ceiling 104
#define Attr_Copy_Sign 105
#define Attr_Floor 106
#define Attr_Fraction 107
#define Attr_Image 108
#define Attr_Input 109
#define Attr_Machine 110
#define Attr_Max 111
#define Attr_Min 112
#define Attr_Model 113
#define Attr_Pred 114
#define Attr_Remainder 115
#define Attr_Rounding 116
#define Attr_Succ 117
#define Attr_Truncation 118
#define Attr_Value 119
#define Attr_Wide_Image 120
#define Attr_Wide_Value 121
#define Attr_Output 121
#define Attr_Read 122
#define Attr_Write 123
#define Attr_Output 122
#define Attr_Read 123
#define Attr_Write 124
#define Attr_Elab_Body 124
#define Attr_Elab_Spec 125
#define Attr_Storage_Pool 126
#define Attr_Elab_Body 125
#define Attr_Elab_Spec 126
#define Attr_Storage_Pool 127
#define Attr_Base 127
#define Attr_Class 128
#define Attr_Base 128
#define Attr_Class 129
/* Define the function to check if a Name_Id value is a valid pragma */

10
gcc/ada/sprint.adb
View File

@ -2817,13 +2817,13 @@ package body Sprint is
Write_Str ("""]");
end Write_Condition_And_Reason;
------------------------
-- Write_Discr_Specs --
------------------------
-----------------------
-- Write_Discr_Specs --
-----------------------
procedure Write_Discr_Specs (N : Node_Id) is
Specs : List_Id;
Spec : Node_Id;
Specs : List_Id;
Spec : Node_Id;
begin
Specs := Discriminant_Specifications (N);

8
gcc/ada/uname.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, 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- --
@ -352,9 +352,9 @@ package body Uname is
return N;
end Get_Parent;
--------------------------------------------
-- Start of Processing for Get_Unit_Name --
--------------------------------------------
-------------------------------------------
-- Start of Processing for Get_Unit_Name --
-------------------------------------------
begin
Node := N;

22
gcc/ada/vms_conv.adb
View File

@ -26,6 +26,7 @@
with Gnatvsn;
with Hostparm;
with Opt;
with Osint; use Osint;
with Ada.Characters.Handling; use Ada.Characters.Handling;
@ -34,6 +35,15 @@ with Ada.Text_IO; use Ada.Text_IO;
package body VMS_Conv is
Keep_Temps_Option : constant Item_Ptr :=
new Item'
(Id => Id_Option,
Name =>
new String'("/KEEP_TEMPORARY_FILES"),
Next => null,
Command => Undefined,
Unix_String => null);
Param_Count : Natural := 0;
-- Number of parameter arguments so far
@ -1288,13 +1298,21 @@ package body VMS_Conv is
raise Normal_Exit;
end if;
-- Special handling for internal debugging switch /?
-- Special handling for internal debugging switch /?
elsif Arg.all = "/?" then
Display_Command := True;
Output_File_Expected := False;
-- Copy -switch unchanged
-- Special handling of internal option /KEEP_TEMPORARY_FILES
elsif Arg'Length >= 7
and then Matching_Name
(Arg.all, Keep_Temps_Option, True) /= null
then
Opt.Keep_Temporary_Files := True;
-- Copy -switch unchanged
elsif Arg (Arg'First) = '-' then
Place (' ');

Some files were not shown because too many files have changed in this diff Show More