[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:
parent
ef5732117a
commit
15ce9ca22b
|
@ -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
|
||||
|
|
|
@ -122,9 +122,9 @@ package body Ada.Exceptions is
|
|||
|
||||
package Exception_Data is
|
||||
|
||||
----------------------------------
|
||||
---------------------------------
|
||||
-- Exception messages routines --
|
||||
----------------------------------
|
||||
---------------------------------
|
||||
|
||||
procedure Set_Exception_C_Msg
|
||||
(Id : Exception_Id;
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 --
|
||||
-------------------------
|
||||
------------------------
|
||||
|
||||
procedure Generate_Interrupt (Interrupt : Interrupt_ID) is
|
||||
begin
|
||||
|
|
|
@ -62,9 +62,9 @@ package body Ada.Numerics.Aux is
|
|||
pragma Inline (Is_Nan);
|
||||
pragma Inline (Reduce);
|
||||
|
||||
---------------------------------
|
||||
--------------------------------
|
||||
-- Basic Elementary Functions --
|
||||
---------------------------------
|
||||
--------------------------------
|
||||
|
||||
-- This section implements a few elementary functions that are used to
|
||||
-- build the more complex ones. This ordering enables better inlining.
|
||||
|
|
|
@ -221,9 +221,9 @@ package body Ada.Tags is
|
|||
|
||||
end HTable_Subprograms;
|
||||
|
||||
--------------------
|
||||
-------------------
|
||||
-- CW_Membership --
|
||||
--------------------
|
||||
-------------------
|
||||
|
||||
-- Canonical implementation of Classwide Membership corresponding to:
|
||||
|
||||
|
|
|
@ -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,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
|
||||
|
||||
|
|
|
@ -4070,9 +4070,9 @@ package body Checks is
|
|||
Reason => CE_Discriminant_Check_Failed));
|
||||
end Generate_Discriminant_Check;
|
||||
|
||||
----------------------------
|
||||
---------------------------
|
||||
-- Generate_Index_Checks --
|
||||
----------------------------
|
||||
---------------------------
|
||||
|
||||
procedure Generate_Index_Checks (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
|
|
@ -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 --
|
||||
-----------------------------------------------
|
||||
----------------------------------------------
|
||||
|
||||
procedure Initialize;
|
||||
-- Routine to initialize following character tables, whose content depends
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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 --
|
||||
---------------------------------
|
||||
--------------------------------
|
||||
|
||||
-- All attributes are manipulated through a procedural interface. This
|
||||
-- section contains the functions used to obtain attribute values which
|
||||
|
|
|
@ -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 --
|
||||
--------------------------
|
||||
-------------------------
|
||||
|
||||
type Elist_Header is record
|
||||
First : Elmt_Id;
|
||||
|
|
|
@ -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 |
|
||||
|
|
|
@ -66,9 +66,9 @@ with Validsw; use Validsw;
|
|||
|
||||
package body Exp_Ch4 is
|
||||
|
||||
------------------------
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
------------------------
|
||||
-----------------------
|
||||
|
||||
procedure Binary_Op_Validity_Checks (N : Node_Id);
|
||||
pragma Inline (Binary_Op_Validity_Checks);
|
||||
|
|
|
@ -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 --
|
||||
-------------------------------
|
||||
------------------------------
|
||||
|
||||
function Cleanup_Protected_Object
|
||||
(N : Node_Id;
|
||||
Ref : Node_Id)
|
||||
return Node_Id
|
||||
Ref : Node_Id) return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
|
||||
|
@ -748,8 +739,7 @@ package body Exp_Ch7 is
|
|||
|
||||
function Cleanup_Task
|
||||
(N : Node_Id;
|
||||
Ref : Node_Id)
|
||||
return 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 --
|
||||
------------------------------------
|
||||
-----------------------------------
|
||||
|
||||
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;
|
||||
|
@ -1425,8 +1414,7 @@ package body Exp_Ch7 is
|
|||
|
||||
function Last_Array_Component
|
||||
(Ref : Node_Id;
|
||||
Typ : Entity_Id)
|
||||
return 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.
|
||||
|
||||
|
@ -1436,8 +1424,7 @@ package body Exp_Ch7 is
|
|||
|
||||
function Last_Array_Component
|
||||
(Ref : Node_Id;
|
||||
Typ : Entity_Id)
|
||||
return Node_Id
|
||||
Typ : Entity_Id) return Node_Id
|
||||
is
|
||||
Index_List : constant List_Id := New_List;
|
||||
|
||||
|
@ -1686,8 +1673,7 @@ package body Exp_Ch7 is
|
|||
|
||||
function Find_Final_List
|
||||
(E : Entity_Id;
|
||||
Ref : Node_Id := Empty)
|
||||
return Node_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;
|
||||
|
@ -2133,8 +2118,7 @@ package body Exp_Ch7 is
|
|||
function Make_Attach_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Flist_Ref : Node_Id;
|
||||
With_Attach : Node_Id)
|
||||
return 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;
|
||||
|
|
|
@ -538,14 +538,14 @@ package body Exp_Dist is
|
|||
end if;
|
||||
end Add_RACW_Features;
|
||||
|
||||
-------------------------------------------------
|
||||
------------------------------------------------
|
||||
-- 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
|
||||
|
|
|
@ -327,9 +327,9 @@ package body Exp_Util is
|
|||
end if;
|
||||
end Build_Runtime_Call;
|
||||
|
||||
-----------------------------
|
||||
----------------------------
|
||||
-- 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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -4398,9 +4398,9 @@ package body Freeze is
|
|||
end if;
|
||||
end Freeze_Subprogram;
|
||||
|
||||
-----------------------
|
||||
----------------------
|
||||
-- Is_Fully_Defined --
|
||||
-----------------------
|
||||
----------------------
|
||||
|
||||
function Is_Fully_Defined (T : Entity_Id) return Boolean is
|
||||
begin
|
||||
|
|
|
@ -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 --
|
||||
--------------------
|
||||
-------------------
|
||||
|
||||
package body Static_HTable is
|
||||
|
||||
|
@ -207,9 +207,9 @@ package body GNAT.Dynamic_HTables is
|
|||
end Set;
|
||||
end Static_HTable;
|
||||
|
||||
--------------------
|
||||
-------------------
|
||||
-- Simple_HTable --
|
||||
--------------------
|
||||
-------------------
|
||||
|
||||
package body Simple_HTable is
|
||||
|
||||
|
|
|
@ -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 --
|
||||
-----------------
|
||||
----------------
|
||||
|
||||
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) | - - - -
|
||||
--
|
||||
|
|
|
@ -2130,8 +2130,18 @@ package body GNAT.Sockets is
|
|||
MS : Timeval_Unit;
|
||||
|
||||
begin
|
||||
-- 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;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,12 +470,14 @@ procedure GNATCmd is
|
|||
Success : Boolean;
|
||||
|
||||
begin
|
||||
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 Opt.Verbose_Mode then
|
||||
if Verbose_Mode then
|
||||
Output.Write_Str ("Deleting temp configuration file """);
|
||||
Output.Write_Str (Get_Name_String
|
||||
Output.Write_Str
|
||||
(Get_Name_String
|
||||
(Projects.Table (Prj).Config_File_Name));
|
||||
Output.Write_Line ("""");
|
||||
end if;
|
||||
|
@ -494,6 +496,7 @@ procedure GNATCmd is
|
|||
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;
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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 --
|
||||
-----------------
|
||||
----------------
|
||||
|
||||
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;
|
||||
|
|
|
@ -701,9 +701,9 @@ package body Inline is
|
|||
end if;
|
||||
end Analyze_Inlined_Bodies;
|
||||
|
||||
--------------------------------
|
||||
-----------------------------
|
||||
-- Check_Body_For_Inlining --
|
||||
--------------------------------
|
||||
-----------------------------
|
||||
|
||||
procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
|
||||
Bname : Unit_Name_Type;
|
||||
|
|
|
@ -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 --
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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,6 +1216,17 @@ package body Makegpr is
|
|||
end if;
|
||||
end loop;
|
||||
|
||||
-- No need to create a global archive, if there is no object
|
||||
-- file to put into.
|
||||
|
||||
Global_Archive_Exists := Last_Argument > First_Object;
|
||||
|
||||
if Global_Archive_Exists then
|
||||
-- If the archive is built, then linking will need to occur
|
||||
-- unconditionally.
|
||||
|
||||
Need_To_Relink := True;
|
||||
|
||||
-- Spawn the archive builder (ar)
|
||||
|
||||
Saved_Last_Argument := Last_Argument;
|
||||
|
@ -1250,7 +1269,8 @@ package body Makegpr is
|
|||
|
||||
Display_Command (Archive_Indexer, Archive_Indexer_Path);
|
||||
|
||||
Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
|
||||
Spawn
|
||||
(Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
|
||||
|
||||
if not Success then
|
||||
|
||||
|
@ -1275,7 +1295,8 @@ package body Makegpr is
|
|||
|
||||
Create_Global_Archive_Dependency_File (Archive_Dep_Name);
|
||||
|
||||
-- Building the archive failed, delete dependency file if one exists
|
||||
-- Building the archive failed, delete dependency file if one
|
||||
-- exists.
|
||||
|
||||
else
|
||||
if Is_Regular_File (Archive_Dep_Name) then
|
||||
|
@ -1290,6 +1311,7 @@ package body Makegpr is
|
|||
""" failed");
|
||||
end if;
|
||||
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, """");
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
-------------------------
|
||||
------------------------
|
||||
|
||||
function Get_RTS_Search_Dir
|
||||
(Search_Dir : String;
|
||||
|
|
|
@ -376,9 +376,9 @@ package body Prj is
|
|||
end if;
|
||||
end Register_Default_Naming_Scheme;
|
||||
|
||||
------------
|
||||
-----------
|
||||
-- Reset --
|
||||
------------
|
||||
-----------
|
||||
|
||||
procedure Reset is
|
||||
begin
|
||||
|
|
|
@ -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,
|
||||
|
||||
|
|
|
@ -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 --
|
||||
-----------------------------
|
||||
----------------------------
|
||||
|
||||
-- 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
|
||||
|
|
|
@ -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 --
|
||||
-------------
|
||||
------------
|
||||
|
||||
procedure Adjust (Object : in out Record_Controller) is
|
||||
|
||||
|
|
|
@ -35,9 +35,9 @@ with Ada.Unchecked_Deallocation;
|
|||
|
||||
package body System.HTable is
|
||||
|
||||
--------------------
|
||||
-------------------
|
||||
-- Static_HTable --
|
||||
--------------------
|
||||
-------------------
|
||||
|
||||
package body Static_HTable is
|
||||
|
||||
|
|
|
@ -255,9 +255,9 @@ package body System.Interrupts is
|
|||
return True;
|
||||
end Has_Interrupt_Or_Attach_Handler;
|
||||
|
||||
----------------
|
||||
--------------
|
||||
-- Finalize --
|
||||
----------------
|
||||
--------------
|
||||
|
||||
procedure Finalize (Object : in out Static_Interrupt_Protection) is
|
||||
begin
|
||||
|
|
|
@ -192,9 +192,9 @@ package body System.Interrupts is
|
|||
|
||||
type Server_Task_Access is access Server_Task;
|
||||
|
||||
--------------------------------
|
||||
-------------------------------
|
||||
-- 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 --
|
||||
---------------------
|
||||
--------------------
|
||||
|
||||
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 --
|
||||
----------------
|
||||
--------------
|
||||
|
||||
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
|
||||
|
|
|
@ -707,18 +707,18 @@ package body System.Interrupts is
|
|||
|
||||
task body Interrupt_Manager is
|
||||
|
||||
----------------------
|
||||
---------------------
|
||||
-- Local Variables --
|
||||
----------------------
|
||||
---------------------
|
||||
|
||||
Intwait_Mask : aliased IMNG.Interrupt_Mask;
|
||||
Ret_Interrupt : Interrupt_ID;
|
||||
Old_Mask : aliased IMNG.Interrupt_Mask;
|
||||
Old_Handler : Parameterless_Handler;
|
||||
|
||||
---------------------
|
||||
--------------------
|
||||
-- Local Routines --
|
||||
---------------------
|
||||
--------------------
|
||||
|
||||
procedure Bind_Handler (Interrupt : Interrupt_ID);
|
||||
-- This procedure does not do anything if the Interrupt is blocked.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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");
|
||||
|
|
|
@ -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.
|
||||
---------------------------------------
|
||||
|
||||
-- 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 --
|
||||
---------------------------
|
||||
-------------------------
|
||||
|
||||
function sigwait
|
||||
(set : access 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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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);
|
||||
|
||||
|
|
|
@ -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 --
|
||||
---------------------------
|
||||
-------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
-- 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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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;
|
||||
|
|
|
@ -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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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;
|
||||
|
|
|
@ -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");
|
||||
|
|
|
@ -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 --
|
||||
-----------------------------------------
|
||||
---------------------------------------
|
||||
|
||||
procedure pthread_init;
|
||||
-- This is a dummy procedure to share some GNULLI files
|
||||
|
||||
---------------------------
|
||||
-------------------------
|
||||
-- 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");
|
||||
|
|
|
@ -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 --
|
||||
---------------------------
|
||||
-------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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;
|
||||
|
|
|
@ -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 --
|
||||
---------------------------
|
||||
-------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
--------------------------
|
||||
|
||||
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");
|
||||
|
|
|
@ -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 --
|
||||
|
|
|
@ -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 --
|
||||
--------------------------
|
||||
------------------------
|
||||
|
||||
function To_Clock_Ticks (D : Duration) return int;
|
||||
-- Convert a duration value (in seconds) into clock ticks.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
------------------
|
||||
----------------
|
||||
|
||||
-- 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);
|
||||
|
||||
|
|
|
@ -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 --
|
||||
-------------------
|
||||
-----------------
|
||||
|
||||
-- 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 --
|
||||
----------------------
|
||||
--------------------
|
||||
|
||||
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;
|
||||
|
||||
|
|
|
@ -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 --
|
||||
------------------
|
||||
----------------
|
||||
|
||||
-- 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
|
||||
|
|
|
@ -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 --
|
||||
------------------
|
||||
----------------
|
||||
|
||||
-- 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));
|
||||
|
|
|
@ -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 --
|
||||
----------------------
|
||||
--------------------
|
||||
|
||||
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,7 +1016,9 @@ 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,
|
||||
Result :=
|
||||
pthread_kill
|
||||
(T.Common.LL.Thread,
|
||||
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
|
||||
pragma Assert (Result = 0);
|
||||
end Abort_Task;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
-------------------
|
||||
-----------------
|
||||
|
||||
-- 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 --
|
||||
--------------------
|
||||
-------------------
|
||||
|
||||
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
|
||||
begin
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
------------------
|
||||
----------------
|
||||
|
||||
-- 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 --
|
||||
----------------------
|
||||
--------------------
|
||||
|
||||
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
|
||||
Mutex_Attr : aliased pthread_mutexattr_t;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -120,9 +120,9 @@ package body System.Tasking.Restricted.Stages is
|
|||
|
||||
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
|
||||
|
||||
------------------------
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
------------------------
|
||||
-----------------------
|
||||
|
||||
procedure Task_Wrapper (Self_ID : Task_Id);
|
||||
-- This is the procedure that is called by the GNULL from the
|
||||
|
|
|
@ -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 --
|
||||
---------------------------
|
||||
--------------------------
|
||||
|
||||
procedure Change_Base_Priority (T : Task_Id);
|
||||
-- Change the base priority of T.
|
||||
|
|
|
@ -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) --
|
||||
----------------------------------------------------------------------
|
||||
-------------------------
|
||||
|
||||
-- Section used by all GNARL implementations (regular and restricted)
|
||||
|
||||
type Common_ATCB is record
|
||||
State : Task_States;
|
||||
|
|
|
@ -443,9 +443,9 @@ package body Scng is
|
|||
Error_Msg_S ("digit expected");
|
||||
end Error_Digit_Expected;
|
||||
|
||||
-------------------
|
||||
------------------
|
||||
-- Scan_Integer --
|
||||
-------------------
|
||||
------------------
|
||||
|
||||
procedure Scan_Integer is
|
||||
C : Character;
|
||||
|
|
|
@ -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 --
|
||||
-----------------------
|
||||
|
|
|
@ -1088,9 +1088,9 @@ package body Sem_Cat is
|
|||
|
||||
end Validate_Object_Declaration;
|
||||
|
||||
--------------------------------
|
||||
-------------------------------
|
||||
-- Validate_RCI_Declarations --
|
||||
--------------------------------
|
||||
-------------------------------
|
||||
|
||||
procedure Validate_RCI_Declarations (P : Entity_Id) is
|
||||
E : Entity_Id;
|
||||
|
|
|
@ -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 --
|
||||
------------------------------
|
||||
-----------------------------
|
||||
|
||||
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 --
|
||||
--------------------
|
||||
------------------
|
||||
|
||||
procedure Check_Parent (P : Node_Id; W : Node_Id) is
|
||||
Item : Node_Id;
|
||||
|
|
|
@ -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 --
|
||||
---------------------------
|
||||
--------------------------
|
||||
|
||||
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 --
|
||||
-----------------------
|
||||
----------------------
|
||||
|
||||
procedure Copy_Descendants is
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1847,9 +1847,9 @@ package body Sem_Ch4 is
|
|||
Operator_Check (N);
|
||||
end Analyze_Negation;
|
||||
|
||||
-------------------
|
||||
------------------
|
||||
-- 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 --
|
||||
----------------------------
|
||||
---------------------------
|
||||
|
||||
procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
|
||||
Op_Name : constant Name_Id := Chars (Op_Id);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -799,9 +799,9 @@ package body Sem_Ch7 is
|
|||
end if;
|
||||
end Is_Public_Child;
|
||||
|
||||
--------------------------------------------
|
||||
------------------------------------------
|
||||
-- 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)
|
||||
|
|
|
@ -549,18 +549,18 @@ package body Sem_Ch8 is
|
|||
end if;
|
||||
end Analyze_Expanded_Name;
|
||||
|
||||
----------------------------------------
|
||||
---------------------------------------
|
||||
-- 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 --
|
||||
---------------------------------------
|
||||
--------------------------------------
|
||||
|
||||
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 --
|
||||
-----------------------------------------
|
||||
----------------------------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
---------------------------
|
||||
|
||||
procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
|
||||
B_Node : Node_Id;
|
||||
|
|
|
@ -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 --
|
||||
--------------------------------
|
||||
-------------------------------
|
||||
|
||||
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;
|
||||
|
||||
|
|
|
@ -5658,9 +5658,9 @@ package body Sem_Prag is
|
|||
Source_Location);
|
||||
end Eliminate;
|
||||
|
||||
--------------------------
|
||||
-------------------------
|
||||
-- Explicit_Overriding --
|
||||
--------------------------
|
||||
-------------------------
|
||||
|
||||
when Pragma_Explicit_Overriding =>
|
||||
Check_Valid_Configuration_Pragma;
|
||||
|
|
|
@ -4974,9 +4974,9 @@ package body Sem_Res is
|
|||
Eval_Integer_Literal (N);
|
||||
end Resolve_Integer_Literal;
|
||||
|
||||
---------------------------------
|
||||
--------------------------------
|
||||
-- Resolve_Intrinsic_Operator --
|
||||
---------------------------------
|
||||
--------------------------------
|
||||
|
||||
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
|
||||
Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
|
||||
|
|
|
@ -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 --
|
||||
----------------------
|
||||
---------------------
|
||||
|
||||
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 --
|
||||
-----------------------
|
||||
----------------------
|
||||
|
||||
procedure Write_Interp_Ref (Map_Ptr : Int) is
|
||||
begin
|
||||
|
|
|
@ -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 --
|
||||
----------------------
|
||||
---------------------
|
||||
|
||||
-- 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
|
||||
|
|
|
@ -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 --
|
||||
-------------------------------------------
|
||||
------------------------------------------
|
||||
|
||||
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_Array_Type (Typ) then
|
||||
return not Is_Constrained (Typ);
|
||||
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
|
||||
|
||||
-- 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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 --
|
||||
-----------------------
|
||||
----------------------
|
||||
|
||||
function Missing_Subunits return Boolean is
|
||||
D : Node_Id;
|
||||
|
|
|
@ -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 --
|
||||
------------------------------------
|
||||
-----------------------------------
|
||||
|
||||
-- COMPONENT_CHOICE_LIST ::=
|
||||
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
|
||||
|
|
|
@ -34,9 +34,9 @@ with Types; use Types;
|
|||
|
||||
package Sinput.L is
|
||||
|
||||
-------------------------------------------
|
||||
------------------------------------------
|
||||
-- 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
|
||||
|
|
|
@ -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
1115
gcc/ada/snames.ads
File diff suppressed because it is too large
Load Diff
189
gcc/ada/snames.h
189
gcc/ada/snames.h
|
@ -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 */
|
||||
|
||||
|
|
|
@ -2817,9 +2817,9 @@ package body Sprint is
|
|||
Write_Str ("""]");
|
||||
end Write_Condition_And_Reason;
|
||||
|
||||
------------------------
|
||||
-----------------------
|
||||
-- Write_Discr_Specs --
|
||||
------------------------
|
||||
-----------------------
|
||||
|
||||
procedure Write_Discr_Specs (N : Node_Id) is
|
||||
Specs : List_Id;
|
||||
|
|
|
@ -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 --
|
||||
--------------------------------------------
|
||||
-------------------------------------------
|
||||
|
||||
begin
|
||||
Node := N;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
@ -1294,6 +1304,14 @@ package body VMS_Conv is
|
|||
Display_Command := True;
|
||||
Output_File_Expected := False;
|
||||
|
||||
-- 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
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue