+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
package Exception_Data is
- ----------------------------------
- -- Exception messages routines --
- ----------------------------------
+ ---------------------------------
+ -- Exception messages routines --
+ ---------------------------------
procedure Set_Exception_C_Msg
(Id : Exception_Id;
-- 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.
-- --
-- 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- --
with System.Interrupt_Management.Operations;
package body Ada.Interrupts.Signal is
- -------------------------
- -- Generate_Interrupt --
- -------------------------
+ ------------------------
+ -- Generate_Interrupt --
+ ------------------------
procedure Generate_Interrupt (Interrupt : Interrupt_ID) is
begin
pragma Inline (Is_Nan);
pragma Inline (Reduce);
- ---------------------------------
- -- Basic Elementary Functions --
- ---------------------------------
+ --------------------------------
+ -- Basic Elementary Functions --
+ --------------------------------
-- This section implements a few elementary functions that are used to
-- build the more complex ones. This ordering enables better inlining.
end HTable_Subprograms;
- --------------------
- -- CW_Membership --
- --------------------
+ -------------------
+ -- CW_Membership --
+ -------------------
-- Canonical implementation of Classwide Membership corresponding to:
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
-- --
-- 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- --
package Bindgen is
- ------------------
- -- Subprograms --
- ------------------
-
procedure Gen_Output_File (Filename : String);
-- Filename is the full path name of the binder output file
if Static and then Siz >= Check_Siz then
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
- Reason => SE_Object_Too_Large));
+ Reason => SE_Object_Too_Large));
Error_Msg_N ("?Storage_Error will be raised at run-time", N);
Uintp.Release (Umark);
return;
Reason => CE_Discriminant_Check_Failed));
end Generate_Discriminant_Check;
- ----------------------------
- -- Generate_Index_Checks --
- ----------------------------
+ ---------------------------
+ -- Generate_Index_Checks --
+ ---------------------------
procedure Generate_Index_Checks (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
-- --
-- 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- --
-- do NOT pack this table, since we don't want the extra overhead of
-- accessing a packed bit string.
- -----------------------------------------------
- -- Character Tables For Current Compilation --
- -----------------------------------------------
+ ----------------------------------------------
+ -- Character Tables For Current Compilation --
+ ----------------------------------------------
procedure Initialize;
-- Routine to initialize following character tables, whose content depends
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);
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);
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);
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);
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);
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,
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);
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");
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;
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");
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");
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;
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;
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,
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");
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;
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;
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;
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);
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);
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,
-- 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.
subtype L is Elist_Id;
subtype S is List_Id;
- ---------------------------------
- -- Attribute Access Functions --
- ---------------------------------
+ --------------------------------
+ -- Attribute Access Functions --
+ --------------------------------
-- All attributes are manipulated through a procedural interface. This
-- section contains the functions used to obtain attribute values which
-- --
-- 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- --
-- is the last item in the list. The Node field points to the node which
-- is referenced by the corresponding list entry.
- --------------------------
- -- Element List Tables --
- --------------------------
+ -------------------------
+ -- Element List Tables --
+ -------------------------
type Elist_Header is record
First : Elmt_Id;
Attribute_Digits |
Attribute_Emax |
Attribute_Epsilon |
+ Attribute_Has_Access_Values |
Attribute_Has_Discriminants |
Attribute_Large |
Attribute_Machine_Emax |
package body Exp_Ch4 is
- ------------------------
- -- Local Subprograms --
- ------------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Binary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Binary_Op_Validity_Checks);
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
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).
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
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
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
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
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;
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;
return Stmts;
end Cleanup_Record;
- -------------------------------
- -- Cleanup_Protected_Object --
- -------------------------------
+ ------------------------------
+ -- Cleanup_Protected_Object --
+ ------------------------------
function Cleanup_Protected_Object
- (N : Node_Id;
- Ref : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Ref : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
------------------
function Cleanup_Task
- (N : Node_Id;
- Ref : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Ref : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
begin
-- If type is not frozen yet, check explicitly among its components,
-- because flag is not necessarily set.
- ------------------------------------
- -- Has_Some_Controlled_Component --
- ------------------------------------
+ -----------------------------------
+ -- Has_Some_Controlled_Component --
+ -----------------------------------
- function Has_Some_Controlled_Component (Rec : Entity_Id)
- return Boolean
+ function Has_Some_Controlled_Component
+ (Rec : Entity_Id) return Boolean
is
Comp : Entity_Id;
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;
Len_Ref : Node_Id := Empty;
function Last_Array_Component
- (Ref : Node_Id;
- Typ : Entity_Id)
- return Node_Id;
+ (Ref : Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Creates a reference to the last component of the array object
-- designated by Ref whose type is Typ.
--------------------------
function Last_Array_Component
- (Ref : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ (Ref : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
Index_List : constant List_Id := New_List;
---------------------
function Find_Final_List
- (E : Entity_Id;
- Ref : Node_Id := Empty)
- return Node_Id
+ (E : Entity_Id;
+ Ref : Node_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Ref);
S : Entity_Id;
(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;
-- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
function Make_Attach_Call
- (Obj_Ref : Node_Id;
- Flist_Ref : Node_Id;
- With_Attach : Node_Id)
- return Node_Id
+ (Obj_Ref : Node_Id;
+ Flist_Ref : Node_Id;
+ With_Attach : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
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;
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);
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;
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;
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;
(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;
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;
end if;
end Add_RACW_Features;
- -------------------------------------------------
- -- Add_RACW_Primitive_Declarations_And_Bodies --
- -------------------------------------------------
+ ------------------------------------------------
+ -- Add_RACW_Primitive_Declarations_And_Bodies --
+ ------------------------------------------------
procedure Add_RACW_Primitive_Declarations_And_Bodies
- (Designated_Type : in Entity_Id;
- Insertion_Node : in Node_Id;
- Decls : in List_Id)
+ (Designated_Type : Entity_Id;
+ Insertion_Node : Node_Id;
+ Decls : List_Id)
is
-- Set sloc of generated declaration to be that of the
-- insertion node, so the declarations are recognized as
end if;
end Build_Runtime_Call;
- -----------------------------
- -- Build_Task_Array_Image --
- -----------------------------
+ ----------------------------
+ -- Build_Task_Array_Image --
+ ----------------------------
-- This function generates the body for a function that constructs the
-- image string for a task that is an array component. The function is
-- 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;
end if;
end Freeze_Subprogram;
- -----------------------
- -- Is_Fully_Defined --
- -----------------------
+ ----------------------
+ -- Is_Fully_Defined --
+ ----------------------
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
-- --
-- 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- --
with Ada.Unchecked_Deallocation;
package body GNAT.Dynamic_HTables is
- --------------------
- -- Static_HTable --
- --------------------
+ -------------------
+ -- Static_HTable --
+ -------------------
package body Static_HTable is
end Set;
end Static_HTable;
- --------------------
- -- Simple_HTable --
- --------------------
+ -------------------
+ -- Simple_HTable --
+ -------------------
package body Simple_HTable is
-- --
-- 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- --
procedure Add_In_Map (C : Character);
-- Add a character in the mapping, if it is not already defined
- -----------------
- -- Add_In_Map --
- -----------------
+ ----------------
+ -- Add_In_Map --
+ ----------------
procedure Add_In_Map (C : Character) is
begin
-- end-state) :
--
-- regexp state_num | a b * empty_string
- -- ------- ---------------------------------------
+ -- ------- ------------------------------
-- a 1 (s) | 2 - - -
-- 2 (e) | - - - -
--
MS : Timeval_Unit;
begin
- S := Timeval_Unit (Val - 0.5);
- MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
+ -- If zero, set result as zero (otherwise it gets rounded down to -1)
+
+ if Val = 0.0 then
+ S := 0;
+ MS := 0;
+
+ -- Normal case where we do round down
+ else
+ S := Timeval_Unit (Val - 0.5);
+ MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
+ end if;
+
return (S, MS);
end To_Timeval;
(@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
@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
-- 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
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;
Success : Boolean;
begin
- if Project /= No_Project then
- for Prj in 1 .. Projects.Last loop
- if Projects.Table (Prj).Config_File_Temp then
- if Opt.Verbose_Mode then
- Output.Write_Str ("Deleting temp configuration file """);
- Output.Write_Str (Get_Name_String
- (Projects.Table (Prj).Config_File_Name));
- Output.Write_Line ("""");
- end if;
+ if not Keep_Temporary_Files then
+ if Project /= No_Project then
+ for Prj in 1 .. Projects.Last loop
+ if Projects.Table (Prj).Config_File_Temp then
+ if Verbose_Mode then
+ Output.Write_Str ("Deleting temp configuration file """);
+ Output.Write_Str
+ (Get_Name_String
+ (Projects.Table (Prj).Config_File_Name));
+ Output.Write_Line ("""");
+ end if;
- Delete_File
- (Name => Get_Name_String
- (Projects.Table (Prj).Config_File_Name),
- Success => Success);
- end if;
- end loop;
- end if;
+ Delete_File
+ (Name => Get_Name_String
+ (Projects.Table (Prj).Config_File_Name),
+ Success => Success);
+ end if;
+ end loop;
+ end if;
- -- If a temporary text file that contains a list of files for a tool
- -- has been created, delete this temporary file.
+ -- If a temporary text file that contains a list of files for a tool
+ -- has been created, delete this temporary file.
- if Temp_File_Name /= null then
- Delete_File (Temp_File_Name.all, Success);
+ if Temp_File_Name /= null then
+ Delete_File (Temp_File_Name.all, Success);
+ end if;
end if;
end Delete_Temp_Config_Files;
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);
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;
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.
return;
else
begin
- if Argument_Count > 1 and then Argument (1) = "-v" then
- Opt.Verbose_Mode := True;
- Command_Arg := 2;
- end if;
+ loop
+ if Argument_Count > Command_Arg
+ and then Argument (Command_Arg) = "-v"
+ then
+ Verbose_Mode := True;
+ Command_Arg := Command_Arg + 1;
+
+ elsif Argument_Count > Command_Arg
+ and then Argument (Command_Arg) = "-dn"
+ then
+ Keep_Temporary_Files := True;
+ Command_Arg := Command_Arg + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
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
-- 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
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
------------------------------------------------------------------------------
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;
-- 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);
-- --
-- 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- --
pfn : PFNTHREAD;
param : PVOID;
flag : ULONG;
- cbStack : ULONG)
- return APIRET;
+ cbStack : ULONG) return APIRET;
pragma Import (C, DosCreateThread, "DosCreateThread");
Block_Child : constant := 1;
function DosGetInfoBlocks
(Pptib : access PTIB;
- Pppib : access PPIB)
- return APIRET;
+ Pppib : access PPIB) return APIRET;
pragma Import (C, DosGetInfoBlocks, "DosGetInfoBlocks");
-- Thread local memory
function DosAllocThreadLocalMemory
(cb : ULONG; -- Number of 4-byte DWORDs to allocate
p : access PVOID) -- Address of the memory block
- return
- APIRET; -- Return Code (rc)
+ return APIRET; -- Return Code (rc)
pragma Import
(Convention => C,
Entity => DosAllocThreadLocalMemory,
Link_Name => "_DosAllocThreadLocalMemory");
- -----------------
- -- Priorities --
- -----------------
+ ----------------
+ -- Priorities --
+ ----------------
function DosSetPriority
(Scope : ULONG;
Class : ULONG;
Delta_P : IC.long;
- PorTid : TID)
- return APIRET;
+ PorTid : TID) return APIRET;
pragma Import (C, DosSetPriority, "DosSetPriority");
PRTYS_PROCESS : constant := 0;
end if;
end Analyze_Inlined_Bodies;
- --------------------------------
- -- Check_Body_For_Inlining --
- --------------------------------
+ -----------------------------
+ -- Check_Body_For_Inlining --
+ -----------------------------
procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
Bname : Unit_Name_Type;
end;
end if;
- Set_Prim_Alignment (E);
+ Set_Elem_Alignment (E);
-- Scalar types: set size and alignment
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
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
Init_Alignment (E, A);
end if;
end;
- end Set_Prim_Alignment;
+ end Set_Elem_Alignment;
----------------------
-- SO_Ref_From_Expr --
-- --
-- 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- --
-- 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;
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.
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;
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
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 &
-- 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???
end if;
end loop;
- -- Spawn the archive builder (ar)
+ -- No need to create a global archive, if there is no object
+ -- file to put into.
- Saved_Last_Argument := Last_Argument;
+ Global_Archive_Exists := Last_Argument > First_Object;
- Last_Argument := First_Object + Max_In_Archives;
+ if Global_Archive_Exists then
+ -- If the archive is built, then linking will need to occur
+ -- unconditionally.
- loop
- if Last_Argument > Saved_Last_Argument then
- Last_Argument := Saved_Last_Argument;
- end if;
+ Need_To_Relink := True;
- Display_Command (Archive_Builder, Archive_Builder_Path);
+ -- Spawn the archive builder (ar)
- Spawn
- (Archive_Builder_Path.all,
- Arguments (1 .. Last_Argument),
- Success);
+ Saved_Last_Argument := Last_Argument;
- exit when not Success;
+ Last_Argument := First_Object + Max_In_Archives;
- exit when Last_Argument = Saved_Last_Argument;
+ loop
+ if Last_Argument > Saved_Last_Argument then
+ Last_Argument := Saved_Last_Argument;
+ end if;
- Arguments (1) := r;
- Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) :=
- Arguments (Last_Argument + 1 .. Saved_Last_Argument);
- Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2;
- end loop;
+ Display_Command (Archive_Builder, Archive_Builder_Path);
- -- If the archive was built, run the archive indexer (ranlib)
- -- if there is one.
+ Spawn
+ (Archive_Builder_Path.all,
+ Arguments (1 .. Last_Argument),
+ Success);
- if Success then
+ exit when not Success;
- -- If the archive was built, run the archive indexer (ranlib),
+ exit when Last_Argument = Saved_Last_Argument;
+
+ Arguments (1) := r;
+ Arguments (3 .. Saved_Last_Argument - Last_Argument + 2) :=
+ Arguments (Last_Argument + 1 .. Saved_Last_Argument);
+ Saved_Last_Argument := Saved_Last_Argument - Last_Argument + 2;
+ end loop;
+
+ -- If the archive was built, run the archive indexer (ranlib)
-- if there is one.
- if Archive_Indexer_Path /= null then
- Last_Argument := 0;
- Add_Argument (Archive_Name, True);
+ if Success then
- Display_Command (Archive_Indexer, Archive_Indexer_Path);
+ -- If the archive was built, run the archive indexer (ranlib),
+ -- if there is one.
- Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
+ if Archive_Indexer_Path /= null then
+ Last_Argument := 0;
+ Add_Argument (Archive_Name, True);
- if not Success then
+ Display_Command (Archive_Indexer, Archive_Indexer_Path);
- -- Running ranlib failed, delete the dependency file,
- -- if it exists.
+ Spawn
+ (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
- if Is_Regular_File (Archive_Dep_Name) then
- Delete_File (Archive_Dep_Name, Success);
- end if;
+ if not Success then
+
+ -- Running ranlib failed, delete the dependency file,
+ -- if it exists.
+
+ if Is_Regular_File (Archive_Dep_Name) then
+ Delete_File (Archive_Dep_Name, Success);
+ end if;
- -- And report the error
+ -- And report the error
- Report_Error
- ("running" & Archive_Indexer & " for project """,
- Get_Name_String (Data.Name),
- """ failed");
- return;
+ Report_Error
+ ("running" & Archive_Indexer & " for project """,
+ Get_Name_String (Data.Name),
+ """ failed");
+ return;
+ end if;
end if;
- end if;
- -- The archive was correctly built, create its dependency file
+ -- The archive was correctly built, create its dependency file
- Create_Global_Archive_Dependency_File (Archive_Dep_Name);
+ 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
- Delete_File (Archive_Dep_Name, Success);
- end if;
+ else
+ if Is_Regular_File (Archive_Dep_Name) then
+ Delete_File (Archive_Dep_Name, Success);
+ end if;
- -- And report the error
+ -- And report the error
- Report_Error
- ("building archive for project """,
- Get_Name_String (Data.Name),
- """ failed");
+ Report_Error
+ ("building archive for project """,
+ Get_Name_String (Data.Name),
+ """ failed");
+ end if;
end if;
end if;
end Build_Global_Archive;
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
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
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
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, """");
-- 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
return Src_Search_Directories.Table (Primary_Directory);
end Get_Primary_Src_Search_Directory;
- -------------------------
- -- Get_RTS_Search_Dir --
- -------------------------
+ ------------------------
+ -- Get_RTS_Search_Dir --
+ ------------------------
function Get_RTS_Search_Dir
(Search_Dir : String;
end if;
end Register_Default_Naming_Scheme;
- ------------
- -- Reset --
- ------------
+ -----------
+ -- Reset --
+ -----------
procedure Reset is
begin
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
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
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,
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,
-- --
-- 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- --
package System.File_Control_Block is
- -----------------------------
- -- Ada File Control Block --
- -----------------------------
+ ----------------------------
+ -- Ada File Control Block --
+ ----------------------------
-- The Ada file control block is an abstract extension of the root
-- stream type. This allows a file to be treated directly as a stream
-- Given the address (obj) of a tagged object, return a
-- pointer to the record controller of this object.
- -------------
- -- Adjust --
- -------------
+ ------------
+ -- Adjust --
+ ------------
procedure Adjust (Object : in out Record_Controller) is
package body System.HTable is
- --------------------
- -- Static_HTable --
- --------------------
+ -------------------
+ -- Static_HTable --
+ -------------------
package body Static_HTable is
return True;
end Has_Interrupt_Or_Attach_Handler;
- ----------------
- -- Finalize --
- ----------------
+ --------------
+ -- Finalize --
+ --------------
procedure Finalize (Object : in out Static_Interrupt_Protection) is
begin
type Server_Task_Access is access Server_Task;
- --------------------------------
- -- Local Types and Variables --
- --------------------------------
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
type Entry_Assoc is record
T : Task_Id;
-- 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" &
task body Interrupt_Manager is
- ---------------------
- -- Local Routines --
- ---------------------
+ --------------------
+ -- Local Routines --
+ --------------------
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
-------------------------------------
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);
return True;
end Has_Interrupt_Or_Attach_Handler;
- ----------------
- -- Finalize --
- ----------------
+ --------------
+ -- Finalize --
+ --------------
procedure Finalize (Object : in out Static_Interrupt_Protection) is
begin
-- ??? loop to be executed only when we're not doing library level
-- finalization, since in this case all interrupt tasks are gone.
+
if not Interrupt_Manager'Terminated then
for N in reverse Object.Previous_Handlers'Range loop
Interrupt_Manager.Attach_Handler
-------------------------------------
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
task body Interrupt_Manager is
- ----------------------
- -- Local Variables --
- ----------------------
+ ---------------------
+ -- Local Variables --
+ ---------------------
Intwait_Mask : aliased IMNG.Interrupt_Mask;
Ret_Interrupt : Interrupt_ID;
Old_Mask : aliased IMNG.Interrupt_Mask;
Old_Handler : Parameterless_Handler;
- ---------------------
- -- Local Routines --
- ---------------------
+ --------------------
+ -- Local Routines --
+ --------------------
procedure Bind_Handler (Interrupt : Interrupt_ID);
-- This procedure does not do anything if the Interrupt is blocked.
(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
-- 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
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
PTHREAD_PRIO_NONE : constant := 0;
PTHREAD_PRIO_PROTECT : constant := 0;
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");
(addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
- -----------------------------------------
- -- Nonstandard Thread Initialization --
- -----------------------------------------
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- --
- -- FreeBSD does not require this so we provide an empty Ada body.
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- FSU_THREADS requires pthread_init, which is nonstandard and
+ -- this should be invoked during the elaboration of s-taprop.adb
+
+ -- FreeBSD does not require this so we provide an empty Ada body
+
procedure pthread_init;
- ---------------------------
- -- POSIX.1c Section 3 --
- ---------------------------
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
function sigwait
(set : access sigset_t;
function pthread_kill
(thread : pthread_t;
- sig : Signal) return int;
+ sig : Signal) return int;
pragma Import (C, pthread_kill, "pthread_kill");
type sigset_t_ptr is access all sigset_t;
oset : sigset_t_ptr) return int;
pragma Import (C, pthread_sigmask, "pthread_sigmask");
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
PTHREAD_PRIO_NONE : constant := 0;
PTHREAD_PRIO_PROTECT : constant := 2;
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");
function pthread_self return pthread_t;
pragma Import (C, pthread_self, "pthread_self");
- ----------------------------
- -- POSIX.1c Section 17 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
function pthread_setspecific
(key : pthread_key_t;
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;
-- #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);
-- 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- --
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
- ---------------------------
- -- POSIX.1c Section 3 --
- ---------------------------
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
function sigwait
(set : access sigset_t;
- sig : access Signal)
- return int
+ sig : access Signal) return int
is
Result : int;
return 0;
end pthread_kill;
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
- -- For all the following functions, DCE Threads has a non standard
- -- behavior: it sets errno but the standard Posix requires it to be
- -- returned.
+ -- For all following functions, DCE Threads has a non standard behavior.
+ -- It sets errno but the standard Posix requires it to be returned.
function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t)
- return int
+ (attr : access pthread_mutexattr_t) return int
is
function pthread_mutexattr_create
- (attr : access pthread_mutexattr_t)
- return int;
+ (attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
begin
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
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
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
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
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
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
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
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
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
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
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
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
function pthread_setscheduler
(thread : pthread_t;
policy : int;
- priority : int)
- return int;
+ priority : int) return int;
pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
begin
-- 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
(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
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");
(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
end if;
end pthread_create;
- ----------------------------
- -- POSIX.1c Section 17 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
function pthread_setspecific
(key : pthread_key_t;
function Get_Stack_Base (thread : pthread_t) return Address is
pragma Warnings (Off, thread);
-
begin
return Null_Address;
end Get_Stack_Base;
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;
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
PTHREAD_PRIO_NONE : constant := 16#100#;
PTHREAD_PRIO_PROTECT : constant := 16#200#;
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;
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");
function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
- -----------------------------------------
- -- Nonstandard Thread Initialization --
- -----------------------------------------
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
procedure pthread_init;
-- This is a dummy procedure to share some GNULLI files
- ---------------------------
- -- POSIX.1c Section 3 --
- ---------------------------
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
function sigwait
(set : access sigset_t;
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");
pragma Inline (pthread_init);
-- This is a dummy procedure to share some GNULLI files
- ---------------------------
- -- POSIX.1c Section 3 --
- ---------------------------
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
function sigwait
(set : access sigset_t;
oset : sigset_t_ptr) return int;
pragma Import (C, pthread_sigmask);
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
function pthread_mutexattr_init (attr : access pthread_mutexattr_t)
return int;
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait");
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t;
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;
(newtype : int; oldtype : access int) return int;
pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
- ---------------------------
- -- POSIX.1c Section 3 --
- ---------------------------
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
function pthread_lock_global_np return int;
pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
function pthread_unlock_global_np return int;
pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
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");
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 --
-- --
-- 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- --
use System.OS_Interface;
use type Interfaces.C.int;
- --------------------------
- -- Internal functions --
- --------------------------
+ ------------------------
+ -- Internal functions --
+ ------------------------
function To_Clock_Ticks (D : Duration) return int;
-- Convert a duration value (in seconds) into clock ticks.
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
- -----------------
- -- Stack_Guard --
- -----------------
+ No_Tasking : Boolean;
+ -- Comment required here ???
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
begin
null;
- end Stack_Guard;
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy version
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
--------------------
- -- Get_Thread_Id --
+ -- Check_No_Locks --
--------------------
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
begin
- return OSI.Thread_Id (T.Common.LL.Thread);
- end Get_Thread_Id;
+ return True;
+ end Check_No_Locks;
- ----------
- -- Self --
- ----------
+ ----------------------
+ -- Environment_Task --
+ ----------------------
- function Self return Task_Id is
+ function Environment_Task return Task_Id is
begin
- return Null_Task;
- end Self;
+ return null;
+ end Environment_Task;
- ---------------------
- -- Initialize_Lock --
- ---------------------
+ -----------------
+ -- Create_Task --
+ -----------------
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : access Lock)
+ 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 Initialize_Lock;
+ end Enter_Task;
- procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
begin
null;
- end Initialize_Lock;
+ end Exit_Task;
-------------------
-- Finalize_Lock --
null;
end Finalize_Lock;
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
- begin
- Ceiling_Violation := False;
- end Write_Lock;
+ ------------------
+ -- Finalize_TCB --
+ ------------------
- procedure Write_Lock
- (L : access RTS_Lock;
- Global_Lock : Boolean := False)
- is
+ procedure Finalize_TCB (T : Task_Id) is
begin
null;
- end Write_Lock;
+ end Finalize_TCB;
- procedure Write_Lock (T : Task_Id) is
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
- null;
- end Write_Lock;
+ return 0;
+ end Get_Priority;
- ---------------
- -- Read_Lock --
- ---------------
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
- procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
- Ceiling_Violation := False;
- end Read_Lock;
+ return OSI.Thread_Id (T.Common.LL.Thread);
+ end Get_Thread_Id;
- ------------
- -- Unlock --
- ------------
+ ----------------
+ -- Initialize --
+ ----------------
- procedure Unlock (L : access Lock) is
+ procedure Initialize (Environment_Task : Task_Id) is
begin
null;
- end Unlock;
+ end Initialize;
- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
begin
null;
- end Unlock;
+ end Initialize_Lock;
- procedure Unlock (T : Task_Id) is
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
begin
null;
- end Unlock;
+ end Initialize_Lock;
- -----------
- -- Sleep --
- -----------
+ --------------------
+ -- Initialize_TCB --
+ --------------------
- procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
- null;
- end Sleep;
+ Succeeded := False;
+ end Initialize_TCB;
- -----------------
- -- Timed_Sleep --
- -----------------
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
- 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
+ function Is_Valid_Task return Boolean is
begin
- Timedout := False;
- Yielded := False;
- end Timed_Sleep;
+ return False;
+ end Is_Valid_Task;
- -----------------
- -- Timed_Delay --
- -----------------
+ --------------
+ -- Lock_RTS --
+ --------------
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes) is
+ procedure Lock_RTS is
begin
null;
- end Timed_Delay;
+ end Lock_RTS;
---------------------
-- Monotonic_Clock --
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 --
--------------
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
- -------------------
- -- Is_Valid_Task --
- -------------------
+ ---------------
+ -- Read_Lock --
+ ---------------
- function Is_Valid_Task return Boolean is
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
- return False;
- end Is_Valid_Task;
+ Ceiling_Violation := False;
+ end Read_Lock;
-----------------------------
-- Register_Foreign_Thread --
return null;
end Register_Foreign_Thread;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ -----------------
+ -- Resume_Task --
+ -----------------
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
begin
- Succeeded := False;
- end Initialize_TCB;
+ return False;
+ end Resume_Task;
- -----------------
- -- Create_Task --
- -----------------
+ -------------------
+ -- RT_Resolution --
+ -------------------
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean) is
+ function RT_Resolution return Duration is
begin
- Succeeded := False;
- end Create_Task;
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return Null_Task;
+ end Self;
------------------
- -- Finalize_TCB --
+ -- Set_Priority --
------------------
- procedure Finalize_TCB (T : Task_Id) is
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
begin
null;
- end Finalize_TCB;
+ end Set_Priority;
- ---------------
- -- Exit_Task --
- ---------------
+ -----------
+ -- Sleep --
+ -----------
- procedure Exit_Task is
+ procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
- end Exit_Task;
+ end Sleep;
- ----------------
- -- Abort_Task --
- ----------------
+ -----------------
+ -- Stack_Guard --
+ -----------------
- procedure Abort_Task (T : Task_Id) is
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
begin
null;
- end Abort_Task;
+ end Stack_Guard;
- -----------
- -- Yield --
- -----------
+ ------------------
+ -- Suspend_Task --
+ ------------------
- procedure Yield (Do_Yield : Boolean := True) is
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
begin
- null;
- end Yield;
-
- ----------------
- -- Check_Exit --
- ----------------
+ return False;
+ end Suspend_Task;
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -----------------
+ -- Timed_Delay --
+ -----------------
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
begin
- return True;
- end Check_Exit;
+ null;
+ end Timed_Delay;
- --------------------
- -- Check_No_Locks --
- --------------------
+ -----------------
+ -- Timed_Sleep --
+ -----------------
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean 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
- return True;
- end Check_No_Locks;
+ Timedout := False;
+ Yielded := False;
+ end Timed_Sleep;
- ----------------------
- -- Environment_Task --
- ----------------------
+ ------------
+ -- Unlock --
+ ------------
- function Environment_Task return Task_Id is
+ procedure Unlock (L : access Lock) is
begin
- return null;
- end Environment_Task;
+ null;
+ end Unlock;
- --------------
- -- Lock_RTS --
- --------------
+ procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
+ begin
+ null;
+ end Unlock;
- procedure Lock_RTS is
+ procedure Unlock (T : Task_Id) is
begin
null;
- end Lock_RTS;
+ end Unlock;
----------------
-- Unlock_RTS --
begin
null;
end Unlock_RTS;
+ ------------
+ -- Wakeup --
+ ------------
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
begin
- return False;
- end Suspend_Task;
+ null;
+ end Wakeup;
- -----------------
- -- Resume_Task --
- -----------------
+ ----------------
+ -- Write_Lock --
+ ----------------
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
begin
- return False;
- end Resume_Task;
+ Ceiling_Violation := False;
+ end Write_Lock;
- ----------------
- -- Initialize --
- ----------------
+ procedure Write_Lock
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ null;
+ end Write_Lock;
- procedure Initialize (Environment_Task : Task_Id) is
+ procedure Write_Lock (T : Task_Id) is
begin
null;
- end Initialize;
+ end Write_Lock;
- No_Tasking : Boolean;
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ null;
+ end Yield;
begin
-- Can't raise an exception because target independent packages try to
-- 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
package PIO renames System.Task_Primitives.Interrupt_Operations;
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
-- 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
-- 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 --
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);
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;
(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);
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);
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
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);
(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;
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;
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);
-- 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);
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Resume_Task;
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
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);
-- 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
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
- -------------------
- -- Stack_Guard --
- -------------------
+ -----------------
+ -- Stack_Guard --
+ -----------------
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
T.Common.Current_Priority := Prio;
Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
pragma Assert (Result /= FUNC_ERR);
-
end Set_Priority;
------------------
return null;
end Register_Foreign_Thread;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
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;
-- 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
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
-- 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");
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 --
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);
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;
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 --
(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;
-- 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;
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;
-- 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;
------------
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
-- 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
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
-- 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");
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.
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 --
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);
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);
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;
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L.L'Access);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
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);
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);
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);
(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;
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);
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;
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));
-- 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
end if;
end Register_Foreign_Thread;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
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;
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
-- 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
-- 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
-- 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
-- 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
end if;
end Abort_Handler;
- -------------------
- -- Stack_Guard --
- -------------------
+ -----------------
+ -- Stack_Guard --
+ -----------------
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
null;
end Stack_Guard;
- --------------------
- -- Get_Thread_Id --
- --------------------
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
end Initialize_Lock;
procedure Initialize_Lock
- (L : access RTS_Lock;
+ (L : access RTS_Lock;
Level : Lock_Level)
is
Result : Interfaces.C.int;
-- 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
-- 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
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
end if;
end Register_Foreign_Thread;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
-- 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
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
- ------------------------
- -- Local Subprograms --
- ------------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Task_Wrapper (Self_ID : Task_Id);
-- This is the procedure that is called by the GNULL from the
-- 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);
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);
-- Returns Boolean'Pos (True) iff abort signal should raise
-- Standard.Abort_Signal. Only used by IRIX currently.
- ---------------------------
- -- Change Base Priority --
- ---------------------------
+ --------------------------
+ -- Change Base Priority --
+ --------------------------
procedure Change_Base_Priority (T : Task_Id);
-- Change the base priority of T.
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);
-- 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.
-- Some protection is described in terms of tasks related to the
-- ATCB being protected. These are:
- -- Self: The task which is controlled by this ATCB.
- -- Acceptor: A task accepting a call from Self.
- -- Caller: A task calling an entry of Self.
- -- Parent: The task executing the master on which Self depends.
- -- Dependent: A task dependent on Self.
- -- Activator: The task that created Self and initiated its activation.
- -- Created: A task created and activated by Self.
+ -- Self: The task which is controlled by this ATCB
+ -- Acceptor: A task accepting a call from Self
+ -- Caller: A task calling an entry of Self
+ -- Parent: The task executing the master on which Self depends
+ -- Dependent: A task dependent on Self
+ -- Activator: The task that created Self and initiated its activation
+ -- Created: A task created and activated by Self
-- Note: The order of the fields is important to implement efficiently
-- tasking support under gdb.
-- Currently gdb relies on the order of the State, Parent, Base_Priority,
-- Task_Image, Task_Image_Len, Call and LL fields.
- ----------------------------------------------------------------------
- -- Common ATCB section --
- -- --
- -- This section is used by all GNARL implementations (regular and --
- -- restricted) --
- ----------------------------------------------------------------------
+ -------------------------
+ -- Common ATCB section --
+ -------------------------
+
+ -- Section used by all GNARL implementations (regular and restricted)
type Common_ATCB is record
State : Task_States;
Error_Msg_S ("digit expected");
end Error_Digit_Expected;
- -------------------
- -- Scan_Integer --
- -------------------
+ ------------------
+ -- Scan_Integer --
+ ------------------
procedure Scan_Integer is
C : Character;
-- 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
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 --
-----------------------
elsif (Id = Attribute_Definite
or else
+ Id = Attribute_Has_Access_Values
+ or else
Id = Attribute_Has_Discriminants
or else
Id = Attribute_Type_Class
-- 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
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 --
-----------------------
end Validate_Object_Declaration;
- --------------------------------
- -- Validate_RCI_Declarations --
- --------------------------------
+ -------------------------------
+ -- Validate_RCI_Declarations --
+ -------------------------------
procedure Validate_RCI_Declarations (P : Entity_Id) is
E : Entity_Id;
-- Remove current scope from scope stack, and preserve the list
-- of use clauses in it, to be reinstalled after context is analyzed.
- ------------------------------
- -- Analyze_Subunit_Context --
- ------------------------------
+ -----------------------------
+ -- Analyze_Subunit_Context --
+ -----------------------------
procedure Analyze_Subunit_Context is
Item : Node_Id;
-- context_clause as a nonlimited with_clause that mentions
-- the same library.
- --------------------
- -- Check_Parent --
- --------------------
+ ------------------
+ -- Check_Parent --
+ ------------------
procedure Check_Parent (P : Node_Id; W : Node_Id) is
Item : Node_Id;
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);
end if;
end Analyze_Package_Instantiation;
- ---------------------------
- -- Inline_Instance_Body --
- ---------------------------
+ --------------------------
+ -- Inline_Instance_Body --
+ --------------------------
procedure Inline_Instance_Body
(N : Node_Id;
-- (for ASIS use) even though as the name of an enclosing generic
-- it would otherwise not be preserved in the generic tree.
- -----------------------
- -- Copy_Descendants --
- -----------------------
+ ----------------------
+ -- Copy_Descendants --
+ ----------------------
procedure Copy_Descendants is
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;
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
Operator_Check (N);
end Analyze_Negation;
- -------------------
- -- Analyze_Null --
- -------------------
+ ------------------
+ -- Analyze_Null --
+ ------------------
procedure Analyze_Null (N : Node_Id) is
begin
end if;
end Analyze_One_Call;
- ----------------------------
- -- Analyze_Operator_Call --
- ----------------------------
+ ---------------------------
+ -- Analyze_Operator_Call --
+ ---------------------------
procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
Op_Name : constant Name_Id := Chars (Op_Id);
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
end if;
end Is_Public_Child;
- --------------------------------------------
- -- Inspect_Deferred_Constant_Completion --
- --------------------------------------------
+ ------------------------------------------
+ -- Inspect_Deferred_Constant_Completion --
+ ------------------------------------------
procedure Inspect_Deferred_Constant_Completion is
Decl : Node_Id;
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
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)
end if;
end Analyze_Expanded_Name;
- ----------------------------------------
- -- Analyze_Generic_Function_Renaming --
- ----------------------------------------
+ ---------------------------------------
+ -- Analyze_Generic_Function_Renaming --
+ ---------------------------------------
procedure Analyze_Generic_Function_Renaming (N : Node_Id) is
begin
Analyze_Generic_Renaming (N, E_Generic_Function);
end Analyze_Generic_Function_Renaming;
- ---------------------------------------
- -- Analyze_Generic_Package_Renaming --
- ---------------------------------------
+ --------------------------------------
+ -- Analyze_Generic_Package_Renaming --
+ --------------------------------------
procedure Analyze_Generic_Package_Renaming (N : Node_Id) is
begin
Analyze_Generic_Renaming (N, E_Generic_Package);
end Analyze_Generic_Package_Renaming;
- -----------------------------------------
- -- Analyze_Generic_Procedure_Renaming --
- -----------------------------------------
+ ----------------------------------------
+ -- Analyze_Generic_Procedure_Renaming --
+ ----------------------------------------
procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is
begin
Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
end Chain_Use_Clause;
- ----------------------------
- -- Check_Frozen_Renaming --
- ----------------------------
+ ---------------------------
+ -- Check_Frozen_Renaming --
+ ---------------------------
procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is
B_Node : Node_Id;
function Check_Controlling_Type
(T : Entity_Id;
- Subp : Entity_Id)
- return Entity_Id;
+ Subp : Entity_Id) return Entity_Id;
-- T is the type of a formal parameter of subp. Returns the tagged
-- if the parameter can be a controlling argument, empty otherwise
- --------------------------------
- -- Add_Dispatching_Operation --
- --------------------------------
+ -------------------------------
+ -- Add_Dispatching_Operation --
+ -------------------------------
procedure Add_Dispatching_Operation
(Tagged_Type : Entity_Id;
New_Op : Entity_Id)
is
List : constant Elist_Id := Primitive_Operations (Tagged_Type);
-
begin
Append_Elmt (New_Op, List);
end Add_Dispatching_Operation;
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;
Source_Location);
end Eliminate;
- --------------------------
- -- Explicit_Overriding --
- --------------------------
+ -------------------------
+ -- Explicit_Overriding --
+ -------------------------
when Pragma_Explicit_Overriding =>
Check_Valid_Configuration_Pragma;
Eval_Integer_Literal (N);
end Resolve_Integer_Literal;
- ---------------------------------
- -- Resolve_Intrinsic_Operator --
- ---------------------------------
+ --------------------------------
+ -- Resolve_Intrinsic_Operator --
+ --------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
-- 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
raise Program_Error;
end Get_First_Interp;
- ----------------------
- -- Get_Next_Interp --
- ----------------------
+ ---------------------
+ -- Get_Next_Interp --
+ ---------------------
procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
begin
end if;
end Write_Overloads;
- -----------------------
- -- Write_Interp_Ref --
- -----------------------
+ ----------------------
+ -- Write_Interp_Ref --
+ ----------------------
procedure Write_Interp_Ref (Map_Ptr : Int) is
begin
-- --
-- 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- --
subtype Interp_Index is Int;
- ----------------------
- -- Error Reporting --
- ----------------------
+ ---------------------
+ -- Error Reporting --
+ ---------------------
-- A common error is the use of an operator in infix notation on arguments
-- of a type that is not directly visible. Rather than diagnosing a type
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;
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 --
----------------------
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
-- Clear current value for entity E and all entities chained to E
- -------------------------------------------
- -- Kill_Current_Values_For_Entity_Chain --
- -------------------------------------------
+ ------------------------------------------
+ -- Kill_Current_Values_For_Entity_Chain --
+ ------------------------------------------
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
Ent : Entity_Id;
end if;
Formal := First_Formal (S);
-
while Present (Formal) loop
-- Match the formals in order. If the corresponding actual
Actual := First (Actuals);
while Present (Actual) loop
-
if Nkind (Actual) = N_Parameter_Association
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
-- 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
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
then
return True;
- -- Unconstrained array types are returned on the secondary stack
+ -- Record type. OK if none of the component types requires a transient
+ -- scope. Note that we already know that this is a definite type (i.e.
+ -- has discriminant defaults if it is a discriminated record).
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Requires_Transient_Scope (Etype (Comp)) then
+ return True;
+ else
+ Next_Entity (Comp);
+ end if;
+ end loop;
+ end;
+
+ return False;
+
+ -- String literal types never require transient scope
+
+ elsif Ekind (Typ) = E_String_Literal_Subtype then
+ return False;
+
+ -- Array type. Note that we already know that this is a constrained
+ -- array, since unconstrained arrays will fail the indefinite test.
elsif Is_Array_Type (Typ) then
- return not Is_Constrained (Typ);
- end if;
- return False;
+ -- If component type requires a transient scope, the array does too
+
+ if Requires_Transient_Scope (Component_Type (Typ)) then
+ return True;
+
+ -- Otherwise, we only need a transient scope if the size is not
+ -- known at compile time.
+
+ else
+ return not Size_Known_At_Compile_Time (Typ);
+ end if;
+
+ -- All other cases do not require a transient scope
+
+ else
+ return False;
+ end if;
end Requires_Transient_Scope;
--------------------------
("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
-- 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
-- from another unit. This is true for entities in packages that are
-- at the library level.
- -----------------------
- -- Missing_Subunits --
- -----------------------
+ ----------------------
+ -- Missing_Subunits --
+ ----------------------
function Missing_Subunits return Boolean is
D : Node_Id;
-- node (which appears as a singleton list). Box_Present gives support
-- to Ada 2005 (AI-287).
- ------------------------------------
- -- 4.3.1 Commponent Choice List --
- ------------------------------------
+ -----------------------------------
+ -- 4.3.1 Commponent Choice List --
+ -----------------------------------
-- COMPONENT_CHOICE_LIST ::=
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
package Sinput.L is
- -------------------------------------------
- -- Subprograms for Loading Source Files --
- -------------------------------------------
+ ------------------------------------------
+ -- Subprograms for Loading Source Files --
+ ------------------------------------------
function Load_Source_File (N : File_Name_Type) return Source_File_Index;
-- Given a source file name, returns the index of the corresponding entry
"target#" &
"req#" &
"obj_typecode#" &
+ "stub#" &
"Oabs#" &
"Oand#" &
"Omod#" &
"first_bit#" &
"fixed_value#" &
"fore#" &
+ "has_access_values#" &
"has_discriminants#" &
"identity#" &
"img#" &
Name_Target : constant Name_Id := N + 085;
Name_Req : constant Name_Id := N + 086;
Name_Obj_TypeCode : constant Name_Id := N + 087;
+ Name_Stub : constant Name_Id := N + 088;
-- Operator Symbol entries. The actual names have an upper case O at
-- the start in place of the Op_ prefix (e.g. the actual name that
-- corresponds to Name_Op_Abs is "Oabs".
- First_Operator_Name : constant Name_Id := N + 088;
- Name_Op_Abs : constant Name_Id := N + 088; -- "abs"
- Name_Op_And : constant Name_Id := N + 089; -- "and"
- Name_Op_Mod : constant Name_Id := N + 090; -- "mod"
- Name_Op_Not : constant Name_Id := N + 091; -- "not"
- Name_Op_Or : constant Name_Id := N + 092; -- "or"
- Name_Op_Rem : constant Name_Id := N + 093; -- "rem"
- Name_Op_Xor : constant Name_Id := N + 094; -- "xor"
- Name_Op_Eq : constant Name_Id := N + 095; -- "="
- Name_Op_Ne : constant Name_Id := N + 096; -- "/="
- Name_Op_Lt : constant Name_Id := N + 097; -- "<"
- Name_Op_Le : constant Name_Id := N + 098; -- "<="
- Name_Op_Gt : constant Name_Id := N + 099; -- ">"
- Name_Op_Ge : constant Name_Id := N + 100; -- ">="
- Name_Op_Add : constant Name_Id := N + 101; -- "+"
- Name_Op_Subtract : constant Name_Id := N + 102; -- "-"
- Name_Op_Concat : constant Name_Id := N + 103; -- "&"
- Name_Op_Multiply : constant Name_Id := N + 104; -- "*"
- Name_Op_Divide : constant Name_Id := N + 105; -- "/"
- Name_Op_Expon : constant Name_Id := N + 106; -- "**"
- Last_Operator_Name : constant Name_Id := N + 106;
+ First_Operator_Name : constant Name_Id := N + 089;
+ Name_Op_Abs : constant Name_Id := N + 089; -- "abs"
+ Name_Op_And : constant Name_Id := N + 090; -- "and"
+ Name_Op_Mod : constant Name_Id := N + 091; -- "mod"
+ Name_Op_Not : constant Name_Id := N + 092; -- "not"
+ Name_Op_Or : constant Name_Id := N + 093; -- "or"
+ Name_Op_Rem : constant Name_Id := N + 094; -- "rem"
+ Name_Op_Xor : constant Name_Id := N + 095; -- "xor"
+ Name_Op_Eq : constant Name_Id := N + 096; -- "="
+ Name_Op_Ne : constant Name_Id := N + 097; -- "/="
+ Name_Op_Lt : constant Name_Id := N + 098; -- "<"
+ Name_Op_Le : constant Name_Id := N + 099; -- "<="
+ Name_Op_Gt : constant Name_Id := N + 100; -- ">"
+ Name_Op_Ge : constant Name_Id := N + 101; -- ">="
+ Name_Op_Add : constant Name_Id := N + 102; -- "+"
+ Name_Op_Subtract : constant Name_Id := N + 103; -- "-"
+ Name_Op_Concat : constant Name_Id := N + 104; -- "&"
+ Name_Op_Multiply : constant Name_Id := N + 105; -- "*"
+ Name_Op_Divide : constant Name_Id := N + 106; -- "/"
+ Name_Op_Expon : constant Name_Id := N + 107; -- "**"
+ Last_Operator_Name : constant Name_Id := N + 107;
-- Names for all pragmas recognized by GNAT. The entries with the comment
-- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
-- only in GNAT for the AAMP. They are ignored in other versions with
-- appropriate warnings.
- First_Pragma_Name : constant Name_Id := N + 107;
+ First_Pragma_Name : constant Name_Id := N + 108;
-- Configuration pragmas are grouped at start
- Name_Ada_83 : constant Name_Id := N + 107; -- GNAT
- Name_Ada_95 : constant Name_Id := N + 108; -- GNAT
- Name_Ada_05 : constant Name_Id := N + 109; -- GNAT
- Name_C_Pass_By_Copy : constant Name_Id := N + 110; -- GNAT
- Name_Compile_Time_Warning : constant Name_Id := N + 111; -- GNAT
- Name_Component_Alignment : constant Name_Id := N + 112; -- GNAT
- Name_Convention_Identifier : constant Name_Id := N + 113; -- GNAT
- Name_Detect_Blocking : constant Name_Id := N + 114; -- Ada05
- Name_Discard_Names : constant Name_Id := N + 115;
- Name_Elaboration_Checks : constant Name_Id := N + 116; -- GNAT
- Name_Eliminate : constant Name_Id := N + 117; -- GNAT
- Name_Explicit_Overriding : constant Name_Id := N + 118;
- Name_Extend_System : constant Name_Id := N + 119; -- GNAT
- Name_Extensions_Allowed : constant Name_Id := N + 120; -- GNAT
- Name_External_Name_Casing : constant Name_Id := N + 121; -- GNAT
- Name_Float_Representation : constant Name_Id := N + 122; -- GNAT
- Name_Initialize_Scalars : constant Name_Id := N + 123; -- GNAT
- Name_Interrupt_State : constant Name_Id := N + 124; -- GNAT
- Name_License : constant Name_Id := N + 125; -- GNAT
- Name_Locking_Policy : constant Name_Id := N + 126;
- Name_Long_Float : constant Name_Id := N + 127; -- VMS
- Name_No_Run_Time : constant Name_Id := N + 128; -- GNAT
- Name_No_Strict_Aliasing : constant Name_Id := N + 129; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 130;
- Name_Polling : constant Name_Id := N + 131; -- GNAT
- Name_Persistent_Data : constant Name_Id := N + 132; -- GNAT
- Name_Persistent_Object : constant Name_Id := N + 133; -- GNAT
- Name_Profile : constant Name_Id := N + 134; -- Ada05
- Name_Profile_Warnings : constant Name_Id := N + 135; -- GNAT
- Name_Propagate_Exceptions : constant Name_Id := N + 136; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 137;
- Name_Ravenscar : constant Name_Id := N + 138;
- Name_Restricted_Run_Time : constant Name_Id := N + 139;
- Name_Restrictions : constant Name_Id := N + 140;
- Name_Restriction_Warnings : constant Name_Id := N + 141; -- GNAT
- Name_Reviewable : constant Name_Id := N + 142;
- Name_Source_File_Name : constant Name_Id := N + 143; -- GNAT
- Name_Source_File_Name_Project : constant Name_Id := N + 144; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 145; -- GNAT
- Name_Suppress : constant Name_Id := N + 146;
- Name_Suppress_Exception_Locations : constant Name_Id := N + 147; -- GNAT
- Name_Task_Dispatching_Policy : constant Name_Id := N + 148;
- Name_Universal_Data : constant Name_Id := N + 149; -- AAMP
- Name_Unsuppress : constant Name_Id := N + 150; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 151; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 152; -- GNAT
- Name_Warnings : constant Name_Id := N + 153; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 153;
+ Name_Ada_83 : constant Name_Id := N + 108; -- GNAT
+ Name_Ada_95 : constant Name_Id := N + 109; -- GNAT
+ Name_Ada_05 : constant Name_Id := N + 110; -- GNAT
+ Name_C_Pass_By_Copy : constant Name_Id := N + 111; -- GNAT
+ Name_Compile_Time_Warning : constant Name_Id := N + 112; -- GNAT
+ Name_Component_Alignment : constant Name_Id := N + 113; -- GNAT
+ Name_Convention_Identifier : constant Name_Id := N + 114; -- GNAT
+ Name_Detect_Blocking : constant Name_Id := N + 115; -- Ada05
+ Name_Discard_Names : constant Name_Id := N + 116;
+ Name_Elaboration_Checks : constant Name_Id := N + 117; -- GNAT
+ Name_Eliminate : constant Name_Id := N + 118; -- GNAT
+ Name_Explicit_Overriding : constant Name_Id := N + 119;
+ Name_Extend_System : constant Name_Id := N + 120; -- GNAT
+ Name_Extensions_Allowed : constant Name_Id := N + 121; -- GNAT
+ Name_External_Name_Casing : constant Name_Id := N + 122; -- GNAT
+ Name_Float_Representation : constant Name_Id := N + 123; -- GNAT
+ Name_Initialize_Scalars : constant Name_Id := N + 124; -- GNAT
+ Name_Interrupt_State : constant Name_Id := N + 125; -- GNAT
+ Name_License : constant Name_Id := N + 126; -- GNAT
+ Name_Locking_Policy : constant Name_Id := N + 127;
+ Name_Long_Float : constant Name_Id := N + 128; -- VMS
+ Name_No_Run_Time : constant Name_Id := N + 129; -- GNAT
+ Name_No_Strict_Aliasing : constant Name_Id := N + 130; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 131;
+ Name_Polling : constant Name_Id := N + 132; -- GNAT
+ Name_Persistent_Data : constant Name_Id := N + 133; -- GNAT
+ Name_Persistent_Object : constant Name_Id := N + 134; -- GNAT
+ Name_Profile : constant Name_Id := N + 135; -- Ada05
+ Name_Profile_Warnings : constant Name_Id := N + 136; -- GNAT
+ Name_Propagate_Exceptions : constant Name_Id := N + 137; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 138;
+ Name_Ravenscar : constant Name_Id := N + 139;
+ Name_Restricted_Run_Time : constant Name_Id := N + 140;
+ Name_Restrictions : constant Name_Id := N + 141;
+ Name_Restriction_Warnings : constant Name_Id := N + 142; -- GNAT
+ Name_Reviewable : constant Name_Id := N + 143;
+ Name_Source_File_Name : constant Name_Id := N + 144; -- GNAT
+ Name_Source_File_Name_Project : constant Name_Id := N + 145; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 146; -- GNAT
+ Name_Suppress : constant Name_Id := N + 147;
+ Name_Suppress_Exception_Locations : constant Name_Id := N + 148; -- GNAT
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 149;
+ Name_Universal_Data : constant Name_Id := N + 150; -- AAMP
+ Name_Unsuppress : constant Name_Id := N + 151; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 152; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 153; -- GNAT
+ Name_Warnings : constant Name_Id := N + 154; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 154;
-- Remaining pragma names
- Name_Abort_Defer : constant Name_Id := N + 154; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 155;
- Name_Annotate : constant Name_Id := N + 156; -- GNAT
+ Name_Abort_Defer : constant Name_Id := N + 155; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 156;
+ Name_Annotate : constant Name_Id := N + 157; -- GNAT
-- Note: AST_Entry is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
-- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
-- AST_Entry is a VMS specific pragma.
- Name_Assert : constant Name_Id := N + 157; -- GNAT
- Name_Asynchronous : constant Name_Id := N + 158;
- Name_Atomic : constant Name_Id := N + 159;
- Name_Atomic_Components : constant Name_Id := N + 160;
- Name_Attach_Handler : constant Name_Id := N + 161;
- Name_Comment : constant Name_Id := N + 162; -- GNAT
- Name_Common_Object : constant Name_Id := N + 163; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 164; -- GNAT
- Name_Controlled : constant Name_Id := N + 165;
- Name_Convention : constant Name_Id := N + 166;
- Name_CPP_Class : constant Name_Id := N + 167; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 168; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 169; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 170; -- GNAT
- Name_Debug : constant Name_Id := N + 171; -- GNAT
- Name_Elaborate : constant Name_Id := N + 172; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 173;
- Name_Elaborate_Body : constant Name_Id := N + 174;
- Name_Export : constant Name_Id := N + 175;
- Name_Export_Exception : constant Name_Id := N + 176; -- VMS
- Name_Export_Function : constant Name_Id := N + 177; -- GNAT
- Name_Export_Object : constant Name_Id := N + 178; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 179; -- GNAT
- Name_Export_Value : constant Name_Id := N + 180; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 181; -- GNAT
- Name_External : constant Name_Id := N + 182; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 183; -- GNAT
- Name_Ident : constant Name_Id := N + 184; -- VMS
- Name_Import : constant Name_Id := N + 185;
- Name_Import_Exception : constant Name_Id := N + 186; -- VMS
- Name_Import_Function : constant Name_Id := N + 187; -- GNAT
- Name_Import_Object : constant Name_Id := N + 188; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 189; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 190; -- GNAT
- Name_Inline : constant Name_Id := N + 191;
- Name_Inline_Always : constant Name_Id := N + 192; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 193; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 194;
- Name_Interface : constant Name_Id := N + 195; -- Ada 83
- Name_Interface_Name : constant Name_Id := N + 196; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 197;
- Name_Interrupt_Priority : constant Name_Id := N + 198;
- Name_Java_Constructor : constant Name_Id := N + 199; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 200; -- GNAT
- Name_Keep_Names : constant Name_Id := N + 201; -- GNAT
- Name_Link_With : constant Name_Id := N + 202; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 203; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 204;
- Name_Linker_Section : constant Name_Id := N + 205; -- GNAT
- Name_List : constant Name_Id := N + 206;
- Name_Machine_Attribute : constant Name_Id := N + 207; -- GNAT
- Name_Main : constant Name_Id := N + 208; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 209; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 210; -- Ada 83
- Name_No_Return : constant Name_Id := N + 211; -- GNAT
- Name_Obsolescent : constant Name_Id := N + 212; -- GNAT
- Name_Optimize : constant Name_Id := N + 213;
- Name_Optional_Overriding : constant Name_Id := N + 214;
- Name_Overriding : constant Name_Id := N + 215;
- Name_Pack : constant Name_Id := N + 216;
- Name_Page : constant Name_Id := N + 217;
- Name_Passive : constant Name_Id := N + 218; -- GNAT
- Name_Preelaborate : constant Name_Id := N + 219;
- Name_Priority : constant Name_Id := N + 220;
- Name_Psect_Object : constant Name_Id := N + 221; -- VMS
- Name_Pure : constant Name_Id := N + 222;
- Name_Pure_Function : constant Name_Id := N + 223; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 224;
- Name_Remote_Types : constant Name_Id := N + 225;
- Name_Share_Generic : constant Name_Id := N + 226; -- GNAT
- Name_Shared : constant Name_Id := N + 227; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 228;
+ Name_Assert : constant Name_Id := N + 158; -- GNAT
+ Name_Asynchronous : constant Name_Id := N + 159;
+ Name_Atomic : constant Name_Id := N + 160;
+ Name_Atomic_Components : constant Name_Id := N + 161;
+ Name_Attach_Handler : constant Name_Id := N + 162;
+ Name_Comment : constant Name_Id := N + 163; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 164; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 165; -- GNAT
+ Name_Controlled : constant Name_Id := N + 166;
+ Name_Convention : constant Name_Id := N + 167;
+ Name_CPP_Class : constant Name_Id := N + 168; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 169; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 170; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 171; -- GNAT
+ Name_Debug : constant Name_Id := N + 172; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 173; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 174;
+ Name_Elaborate_Body : constant Name_Id := N + 175;
+ Name_Export : constant Name_Id := N + 176;
+ Name_Export_Exception : constant Name_Id := N + 177; -- VMS
+ Name_Export_Function : constant Name_Id := N + 178; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 179; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 180; -- GNAT
+ Name_Export_Value : constant Name_Id := N + 181; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 182; -- GNAT
+ Name_External : constant Name_Id := N + 183; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 184; -- GNAT
+ Name_Ident : constant Name_Id := N + 185; -- VMS
+ Name_Import : constant Name_Id := N + 186;
+ Name_Import_Exception : constant Name_Id := N + 187; -- VMS
+ Name_Import_Function : constant Name_Id := N + 188; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 189; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 190; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 191; -- GNAT
+ Name_Inline : constant Name_Id := N + 192;
+ Name_Inline_Always : constant Name_Id := N + 193; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 194; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 195;
+ Name_Interface : constant Name_Id := N + 196; -- Ada 83
+ Name_Interface_Name : constant Name_Id := N + 197; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 198;
+ Name_Interrupt_Priority : constant Name_Id := N + 199;
+ Name_Java_Constructor : constant Name_Id := N + 200; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 201; -- GNAT
+ Name_Keep_Names : constant Name_Id := N + 202; -- GNAT
+ Name_Link_With : constant Name_Id := N + 203; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 204; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 205;
+ Name_Linker_Section : constant Name_Id := N + 206; -- GNAT
+ Name_List : constant Name_Id := N + 207;
+ Name_Machine_Attribute : constant Name_Id := N + 208; -- GNAT
+ Name_Main : constant Name_Id := N + 209; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 210; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 211; -- Ada 83
+ Name_No_Return : constant Name_Id := N + 212; -- GNAT
+ Name_Obsolescent : constant Name_Id := N + 213; -- GNAT
+ Name_Optimize : constant Name_Id := N + 214;
+ Name_Optional_Overriding : constant Name_Id := N + 215;
+ Name_Overriding : constant Name_Id := N + 216;
+ Name_Pack : constant Name_Id := N + 217;
+ Name_Page : constant Name_Id := N + 218;
+ Name_Passive : constant Name_Id := N + 219; -- GNAT
+ Name_Preelaborate : constant Name_Id := N + 220;
+ Name_Priority : constant Name_Id := N + 221;
+ Name_Psect_Object : constant Name_Id := N + 222; -- VMS
+ Name_Pure : constant Name_Id := N + 223;
+ Name_Pure_Function : constant Name_Id := N + 224; -- GNAT
+ Name_Remote_Call_Interface : constant Name_Id := N + 225;
+ Name_Remote_Types : constant Name_Id := N + 226;
+ Name_Share_Generic : constant Name_Id := N + 227; -- GNAT
+ Name_Shared : constant Name_Id := N + 228; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 229;
-- Note: Storage_Size is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
-- Note: Storage_Unit is also omitted from the list because of a clash
-- with an attribute name, and is treated similarly.
- Name_Source_Reference : constant Name_Id := N + 229; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 230; -- GNAT
- Name_Subtitle : constant Name_Id := N + 231; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 232; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 233; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 234; -- GNAT
- Name_System_Name : constant Name_Id := N + 235; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 236; -- GNAT
- Name_Task_Name : constant Name_Id := N + 237; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 238; -- VMS
- Name_Thread_Body : constant Name_Id := N + 239; -- GNAT
- Name_Time_Slice : constant Name_Id := N + 240; -- GNAT
- Name_Title : constant Name_Id := N + 241; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 242; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 243; -- GNAT
- Name_Unreferenced : constant Name_Id := N + 244; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 245; -- GNAT
- Name_Volatile : constant Name_Id := N + 246;
- Name_Volatile_Components : constant Name_Id := N + 247;
- Name_Weak_External : constant Name_Id := N + 248; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 248;
+ Name_Source_Reference : constant Name_Id := N + 230; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 231; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 232; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 233; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 234; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 235; -- GNAT
+ Name_System_Name : constant Name_Id := N + 236; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 237; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 238; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 239; -- VMS
+ Name_Thread_Body : constant Name_Id := N + 240; -- GNAT
+ Name_Time_Slice : constant Name_Id := N + 241; -- GNAT
+ Name_Title : constant Name_Id := N + 242; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 243; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 244; -- GNAT
+ Name_Unreferenced : constant Name_Id := N + 245; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 246; -- GNAT
+ Name_Volatile : constant Name_Id := N + 247;
+ Name_Volatile_Components : constant Name_Id := N + 248;
+ Name_Weak_External : constant Name_Id := N + 249; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 249;
-- Language convention names for pragma Convention/Export/Import/Interface
-- Note that Name_C is not included in this list, since it was already
-- Entry and Protected, this is because these conventions cannot be
-- specified by a pragma.
- First_Convention_Name : constant Name_Id := N + 249;
- Name_Ada : constant Name_Id := N + 249;
- Name_Assembler : constant Name_Id := N + 250;
- Name_COBOL : constant Name_Id := N + 251;
- Name_CPP : constant Name_Id := N + 252;
- Name_Fortran : constant Name_Id := N + 253;
- Name_Intrinsic : constant Name_Id := N + 254;
- Name_Java : constant Name_Id := N + 255;
- Name_Stdcall : constant Name_Id := N + 256;
- Name_Stubbed : constant Name_Id := N + 257;
- Last_Convention_Name : constant Name_Id := N + 257;
+ First_Convention_Name : constant Name_Id := N + 250;
+ Name_Ada : constant Name_Id := N + 250;
+ Name_Assembler : constant Name_Id := N + 251;
+ Name_COBOL : constant Name_Id := N + 252;
+ Name_CPP : constant Name_Id := N + 253;
+ Name_Fortran : constant Name_Id := N + 254;
+ Name_Intrinsic : constant Name_Id := N + 255;
+ Name_Java : constant Name_Id := N + 256;
+ Name_Stdcall : constant Name_Id := N + 257;
+ Name_Stubbed : constant Name_Id := N + 258;
+ Last_Convention_Name : constant Name_Id := N + 258;
-- The following names are preset as synonyms for Assembler
- Name_Asm : constant Name_Id := N + 258;
- Name_Assembly : constant Name_Id := N + 259;
+ Name_Asm : constant Name_Id := N + 259;
+ Name_Assembly : constant Name_Id := N + 260;
-- The following names are preset as synonyms for C
- Name_Default : constant Name_Id := N + 260;
+ Name_Default : constant Name_Id := N + 261;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
- Name_DLL : constant Name_Id := N + 261;
- Name_Win32 : constant Name_Id := N + 262;
+ Name_DLL : constant Name_Id := N + 262;
+ Name_Win32 : constant Name_Id := N + 263;
-- Other special names used in processing pragmas
- Name_As_Is : constant Name_Id := N + 263;
- Name_Body_File_Name : constant Name_Id := N + 264;
- Name_Boolean_Entry_Barriers : constant Name_Id := N + 265;
- Name_Casing : constant Name_Id := N + 266;
- Name_Code : constant Name_Id := N + 267;
- Name_Component : constant Name_Id := N + 268;
- Name_Component_Size_4 : constant Name_Id := N + 269;
- Name_Copy : constant Name_Id := N + 270;
- Name_D_Float : constant Name_Id := N + 271;
- Name_Descriptor : constant Name_Id := N + 272;
- Name_Dot_Replacement : constant Name_Id := N + 273;
- Name_Dynamic : constant Name_Id := N + 274;
- Name_Entity : constant Name_Id := N + 275;
- Name_External_Name : constant Name_Id := N + 276;
- Name_First_Optional_Parameter : constant Name_Id := N + 277;
- Name_Form : constant Name_Id := N + 278;
- Name_G_Float : constant Name_Id := N + 279;
- Name_Gcc : constant Name_Id := N + 280;
- Name_Gnat : constant Name_Id := N + 281;
- Name_GPL : constant Name_Id := N + 282;
- Name_IEEE_Float : constant Name_Id := N + 283;
- Name_Internal : constant Name_Id := N + 284;
- Name_Link_Name : constant Name_Id := N + 285;
- Name_Lowercase : constant Name_Id := N + 286;
- Name_Max_Entry_Queue_Depth : constant Name_Id := N + 287;
- Name_Max_Entry_Queue_Length : constant Name_Id := N + 288;
- Name_Max_Size : constant Name_Id := N + 289;
- Name_Mechanism : constant Name_Id := N + 290;
- Name_Mixedcase : constant Name_Id := N + 291;
- Name_Modified_GPL : constant Name_Id := N + 292;
- Name_Name : constant Name_Id := N + 293;
- Name_NCA : constant Name_Id := N + 294;
- Name_No : constant Name_Id := N + 295;
- Name_On : constant Name_Id := N + 296;
- Name_Parameter_Types : constant Name_Id := N + 297;
- Name_Reference : constant Name_Id := N + 298;
- Name_No_Dynamic_Attachment : constant Name_Id := N + 299;
- Name_No_Dynamic_Interrupts : constant Name_Id := N + 300;
- Name_No_Requeue : constant Name_Id := N + 301;
- Name_No_Requeue_Statements : constant Name_Id := N + 302;
- Name_No_Task_Attributes : constant Name_Id := N + 303;
- Name_No_Task_Attributes_Package : constant Name_Id := N + 304;
- Name_Restricted : constant Name_Id := N + 305;
- Name_Result_Mechanism : constant Name_Id := N + 306;
- Name_Result_Type : constant Name_Id := N + 307;
- Name_Runtime : constant Name_Id := N + 308;
- Name_SB : constant Name_Id := N + 309;
- Name_Secondary_Stack_Size : constant Name_Id := N + 310;
- Name_Section : constant Name_Id := N + 311;
- Name_Semaphore : constant Name_Id := N + 312;
- Name_Simple_Barriers : constant Name_Id := N + 313;
- Name_Spec_File_Name : constant Name_Id := N + 314;
- Name_Static : constant Name_Id := N + 315;
- Name_Stack_Size : constant Name_Id := N + 316;
- Name_Subunit_File_Name : constant Name_Id := N + 317;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 318;
- Name_Task_Type : constant Name_Id := N + 319;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 320;
- Name_Top_Guard : constant Name_Id := N + 321;
- Name_UBA : constant Name_Id := N + 322;
- Name_UBS : constant Name_Id := N + 323;
- Name_UBSB : constant Name_Id := N + 324;
- Name_Unit_Name : constant Name_Id := N + 325;
- Name_Unknown : constant Name_Id := N + 326;
- Name_Unrestricted : constant Name_Id := N + 327;
- Name_Uppercase : constant Name_Id := N + 328;
- Name_User : constant Name_Id := N + 329;
- Name_VAX_Float : constant Name_Id := N + 330;
- Name_VMS : constant Name_Id := N + 331;
- Name_Working_Storage : constant Name_Id := N + 332;
+ Name_As_Is : constant Name_Id := N + 264;
+ Name_Body_File_Name : constant Name_Id := N + 265;
+ Name_Boolean_Entry_Barriers : constant Name_Id := N + 266;
+ Name_Casing : constant Name_Id := N + 267;
+ Name_Code : constant Name_Id := N + 268;
+ Name_Component : constant Name_Id := N + 269;
+ Name_Component_Size_4 : constant Name_Id := N + 270;
+ Name_Copy : constant Name_Id := N + 271;
+ Name_D_Float : constant Name_Id := N + 272;
+ Name_Descriptor : constant Name_Id := N + 273;
+ Name_Dot_Replacement : constant Name_Id := N + 274;
+ Name_Dynamic : constant Name_Id := N + 275;
+ Name_Entity : constant Name_Id := N + 276;
+ Name_External_Name : constant Name_Id := N + 277;
+ Name_First_Optional_Parameter : constant Name_Id := N + 278;
+ Name_Form : constant Name_Id := N + 279;
+ Name_G_Float : constant Name_Id := N + 280;
+ Name_Gcc : constant Name_Id := N + 281;
+ Name_Gnat : constant Name_Id := N + 282;
+ Name_GPL : constant Name_Id := N + 283;
+ Name_IEEE_Float : constant Name_Id := N + 284;
+ Name_Internal : constant Name_Id := N + 285;
+ Name_Link_Name : constant Name_Id := N + 286;
+ Name_Lowercase : constant Name_Id := N + 287;
+ Name_Max_Entry_Queue_Depth : constant Name_Id := N + 288;
+ Name_Max_Entry_Queue_Length : constant Name_Id := N + 289;
+ Name_Max_Size : constant Name_Id := N + 290;
+ Name_Mechanism : constant Name_Id := N + 291;
+ Name_Mixedcase : constant Name_Id := N + 292;
+ Name_Modified_GPL : constant Name_Id := N + 293;
+ Name_Name : constant Name_Id := N + 294;
+ Name_NCA : constant Name_Id := N + 295;
+ Name_No : constant Name_Id := N + 296;
+ Name_On : constant Name_Id := N + 297;
+ Name_Parameter_Types : constant Name_Id := N + 298;
+ Name_Reference : constant Name_Id := N + 299;
+ Name_No_Dynamic_Attachment : constant Name_Id := N + 300;
+ Name_No_Dynamic_Interrupts : constant Name_Id := N + 301;
+ Name_No_Requeue : constant Name_Id := N + 302;
+ Name_No_Requeue_Statements : constant Name_Id := N + 303;
+ Name_No_Task_Attributes : constant Name_Id := N + 304;
+ Name_No_Task_Attributes_Package : constant Name_Id := N + 305;
+ Name_Restricted : constant Name_Id := N + 306;
+ Name_Result_Mechanism : constant Name_Id := N + 307;
+ Name_Result_Type : constant Name_Id := N + 308;
+ Name_Runtime : constant Name_Id := N + 309;
+ Name_SB : constant Name_Id := N + 310;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 311;
+ Name_Section : constant Name_Id := N + 312;
+ Name_Semaphore : constant Name_Id := N + 313;
+ Name_Simple_Barriers : constant Name_Id := N + 314;
+ Name_Spec_File_Name : constant Name_Id := N + 315;
+ Name_Static : constant Name_Id := N + 316;
+ Name_Stack_Size : constant Name_Id := N + 317;
+ Name_Subunit_File_Name : constant Name_Id := N + 318;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 319;
+ Name_Task_Type : constant Name_Id := N + 320;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 321;
+ Name_Top_Guard : constant Name_Id := N + 322;
+ Name_UBA : constant Name_Id := N + 323;
+ Name_UBS : constant Name_Id := N + 324;
+ Name_UBSB : constant Name_Id := N + 325;
+ Name_Unit_Name : constant Name_Id := N + 326;
+ Name_Unknown : constant Name_Id := N + 327;
+ Name_Unrestricted : constant Name_Id := N + 328;
+ Name_Uppercase : constant Name_Id := N + 329;
+ Name_User : constant Name_Id := N + 330;
+ Name_VAX_Float : constant Name_Id := N + 331;
+ Name_VMS : constant Name_Id := N + 332;
+ Name_Working_Storage : constant Name_Id := N + 333;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
- First_Attribute_Name : constant Name_Id := N + 333;
- Name_Abort_Signal : constant Name_Id := N + 333; -- GNAT
- Name_Access : constant Name_Id := N + 334;
- Name_Address : constant Name_Id := N + 335;
- Name_Address_Size : constant Name_Id := N + 336; -- GNAT
- Name_Aft : constant Name_Id := N + 337;
- Name_Alignment : constant Name_Id := N + 338;
- Name_Asm_Input : constant Name_Id := N + 339; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 340; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 341; -- VMS
- Name_Bit : constant Name_Id := N + 342; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 343;
- Name_Bit_Position : constant Name_Id := N + 344; -- GNAT
- Name_Body_Version : constant Name_Id := N + 345;
- Name_Callable : constant Name_Id := N + 346;
- Name_Caller : constant Name_Id := N + 347;
- Name_Code_Address : constant Name_Id := N + 348; -- GNAT
- Name_Component_Size : constant Name_Id := N + 349;
- Name_Compose : constant Name_Id := N + 350;
- Name_Constrained : constant Name_Id := N + 351;
- Name_Count : constant Name_Id := N + 352;
- Name_Default_Bit_Order : constant Name_Id := N + 353; -- GNAT
- Name_Definite : constant Name_Id := N + 354;
- Name_Delta : constant Name_Id := N + 355;
- Name_Denorm : constant Name_Id := N + 356;
- Name_Digits : constant Name_Id := N + 357;
- Name_Elaborated : constant Name_Id := N + 358; -- GNAT
- Name_Emax : constant Name_Id := N + 359; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 360; -- GNAT
- Name_Epsilon : constant Name_Id := N + 361; -- Ada 83
- Name_Exponent : constant Name_Id := N + 362;
- Name_External_Tag : constant Name_Id := N + 363;
- Name_First : constant Name_Id := N + 364;
- Name_First_Bit : constant Name_Id := N + 365;
- Name_Fixed_Value : constant Name_Id := N + 366; -- GNAT
- Name_Fore : constant Name_Id := N + 367;
- Name_Has_Discriminants : constant Name_Id := N + 368; -- GNAT
- Name_Identity : constant Name_Id := N + 369;
- Name_Img : constant Name_Id := N + 370; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 371; -- GNAT
- Name_Large : constant Name_Id := N + 372; -- Ada 83
- Name_Last : constant Name_Id := N + 373;
- Name_Last_Bit : constant Name_Id := N + 374;
- Name_Leading_Part : constant Name_Id := N + 375;
- Name_Length : constant Name_Id := N + 376;
- Name_Machine_Emax : constant Name_Id := N + 377;
- Name_Machine_Emin : constant Name_Id := N + 378;
- Name_Machine_Mantissa : constant Name_Id := N + 379;
- Name_Machine_Overflows : constant Name_Id := N + 380;
- Name_Machine_Radix : constant Name_Id := N + 381;
- Name_Machine_Rounds : constant Name_Id := N + 382;
- Name_Machine_Size : constant Name_Id := N + 383; -- GNAT
- Name_Mantissa : constant Name_Id := N + 384; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 385;
- Name_Maximum_Alignment : constant Name_Id := N + 386; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 387; -- GNAT
- Name_Model_Emin : constant Name_Id := N + 388;
- Name_Model_Epsilon : constant Name_Id := N + 389;
- Name_Model_Mantissa : constant Name_Id := N + 390;
- Name_Model_Small : constant Name_Id := N + 391;
- Name_Modulus : constant Name_Id := N + 392;
- Name_Null_Parameter : constant Name_Id := N + 393; -- GNAT
- Name_Object_Size : constant Name_Id := N + 394; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 395;
- Name_Passed_By_Reference : constant Name_Id := N + 396; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 397;
- Name_Pos : constant Name_Id := N + 398;
- Name_Position : constant Name_Id := N + 399;
- Name_Range : constant Name_Id := N + 400;
- Name_Range_Length : constant Name_Id := N + 401; -- GNAT
- Name_Round : constant Name_Id := N + 402;
- Name_Safe_Emax : constant Name_Id := N + 403; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 404;
- Name_Safe_Large : constant Name_Id := N + 405; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 406;
- Name_Safe_Small : constant Name_Id := N + 407; -- Ada 83
- Name_Scale : constant Name_Id := N + 408;
- Name_Scaling : constant Name_Id := N + 409;
- Name_Signed_Zeros : constant Name_Id := N + 410;
- Name_Size : constant Name_Id := N + 411;
- Name_Small : constant Name_Id := N + 412;
- Name_Storage_Size : constant Name_Id := N + 413;
- Name_Storage_Unit : constant Name_Id := N + 414; -- GNAT
- Name_Tag : constant Name_Id := N + 415;
- Name_Target_Name : constant Name_Id := N + 416; -- GNAT
- Name_Terminated : constant Name_Id := N + 417;
- Name_To_Address : constant Name_Id := N + 418; -- GNAT
- Name_Type_Class : constant Name_Id := N + 419; -- GNAT
- Name_UET_Address : constant Name_Id := N + 420; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 421;
- Name_Unchecked_Access : constant Name_Id := N + 422;
- Name_Unconstrained_Array : constant Name_Id := N + 423;
- Name_Universal_Literal_String : constant Name_Id := N + 424; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 425; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 426; -- GNAT
- Name_Val : constant Name_Id := N + 427;
- Name_Valid : constant Name_Id := N + 428;
- Name_Value_Size : constant Name_Id := N + 429; -- GNAT
- Name_Version : constant Name_Id := N + 430;
- Name_Wchar_T_Size : constant Name_Id := N + 431; -- GNAT
- Name_Wide_Width : constant Name_Id := N + 432;
- Name_Width : constant Name_Id := N + 433;
- Name_Word_Size : constant Name_Id := N + 434; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 334;
+ Name_Abort_Signal : constant Name_Id := N + 334; -- GNAT
+ Name_Access : constant Name_Id := N + 335;
+ Name_Address : constant Name_Id := N + 336;
+ Name_Address_Size : constant Name_Id := N + 337; -- GNAT
+ Name_Aft : constant Name_Id := N + 338;
+ Name_Alignment : constant Name_Id := N + 339;
+ Name_Asm_Input : constant Name_Id := N + 340; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 341; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 342; -- VMS
+ Name_Bit : constant Name_Id := N + 343; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 344;
+ Name_Bit_Position : constant Name_Id := N + 345; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 346;
+ Name_Callable : constant Name_Id := N + 347;
+ Name_Caller : constant Name_Id := N + 348;
+ Name_Code_Address : constant Name_Id := N + 349; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 350;
+ Name_Compose : constant Name_Id := N + 351;
+ Name_Constrained : constant Name_Id := N + 352;
+ Name_Count : constant Name_Id := N + 353;
+ Name_Default_Bit_Order : constant Name_Id := N + 354; -- GNAT
+ Name_Definite : constant Name_Id := N + 355;
+ Name_Delta : constant Name_Id := N + 356;
+ Name_Denorm : constant Name_Id := N + 357;
+ Name_Digits : constant Name_Id := N + 358;
+ Name_Elaborated : constant Name_Id := N + 359; -- GNAT
+ Name_Emax : constant Name_Id := N + 360; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 361; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 362; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 363;
+ Name_External_Tag : constant Name_Id := N + 364;
+ Name_First : constant Name_Id := N + 365;
+ Name_First_Bit : constant Name_Id := N + 366;
+ Name_Fixed_Value : constant Name_Id := N + 367; -- GNAT
+ Name_Fore : constant Name_Id := N + 368;
+ Name_Has_Access_Values : constant Name_Id := N + 369; -- GNAT
+ Name_Has_Discriminants : constant Name_Id := N + 370; -- GNAT
+ Name_Identity : constant Name_Id := N + 371;
+ Name_Img : constant Name_Id := N + 372; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 373; -- GNAT
+ Name_Large : constant Name_Id := N + 374; -- Ada 83
+ Name_Last : constant Name_Id := N + 375;
+ Name_Last_Bit : constant Name_Id := N + 376;
+ Name_Leading_Part : constant Name_Id := N + 377;
+ Name_Length : constant Name_Id := N + 378;
+ Name_Machine_Emax : constant Name_Id := N + 379;
+ Name_Machine_Emin : constant Name_Id := N + 380;
+ Name_Machine_Mantissa : constant Name_Id := N + 381;
+ Name_Machine_Overflows : constant Name_Id := N + 382;
+ Name_Machine_Radix : constant Name_Id := N + 383;
+ Name_Machine_Rounds : constant Name_Id := N + 384;
+ Name_Machine_Size : constant Name_Id := N + 385; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 386; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 387;
+ Name_Maximum_Alignment : constant Name_Id := N + 388; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 389; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 390;
+ Name_Model_Epsilon : constant Name_Id := N + 391;
+ Name_Model_Mantissa : constant Name_Id := N + 392;
+ Name_Model_Small : constant Name_Id := N + 393;
+ Name_Modulus : constant Name_Id := N + 394;
+ Name_Null_Parameter : constant Name_Id := N + 395; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 396; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 397;
+ Name_Passed_By_Reference : constant Name_Id := N + 398; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 399;
+ Name_Pos : constant Name_Id := N + 400;
+ Name_Position : constant Name_Id := N + 401;
+ Name_Range : constant Name_Id := N + 402;
+ Name_Range_Length : constant Name_Id := N + 403; -- GNAT
+ Name_Round : constant Name_Id := N + 404;
+ Name_Safe_Emax : constant Name_Id := N + 405; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 406;
+ Name_Safe_Large : constant Name_Id := N + 407; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 408;
+ Name_Safe_Small : constant Name_Id := N + 409; -- Ada 83
+ Name_Scale : constant Name_Id := N + 410;
+ Name_Scaling : constant Name_Id := N + 411;
+ Name_Signed_Zeros : constant Name_Id := N + 412;
+ Name_Size : constant Name_Id := N + 413;
+ Name_Small : constant Name_Id := N + 414;
+ Name_Storage_Size : constant Name_Id := N + 415;
+ Name_Storage_Unit : constant Name_Id := N + 416; -- GNAT
+ Name_Tag : constant Name_Id := N + 417;
+ Name_Target_Name : constant Name_Id := N + 418; -- GNAT
+ Name_Terminated : constant Name_Id := N + 419;
+ Name_To_Address : constant Name_Id := N + 420; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 421; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 422; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 423;
+ Name_Unchecked_Access : constant Name_Id := N + 424;
+ Name_Unconstrained_Array : constant Name_Id := N + 425;
+ Name_Universal_Literal_String : constant Name_Id := N + 426; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 427; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 428; -- GNAT
+ Name_Val : constant Name_Id := N + 429;
+ Name_Valid : constant Name_Id := N + 430;
+ Name_Value_Size : constant Name_Id := N + 431; -- GNAT
+ Name_Version : constant Name_Id := N + 432;
+ Name_Wchar_T_Size : constant Name_Id := N + 433; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 434;
+ Name_Width : constant Name_Id := N + 435;
+ Name_Word_Size : constant Name_Id := N + 436; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value.
- First_Renamable_Function_Attribute : constant Name_Id := N + 435;
- Name_Adjacent : constant Name_Id := N + 435;
- Name_Ceiling : constant Name_Id := N + 436;
- Name_Copy_Sign : constant Name_Id := N + 437;
- Name_Floor : constant Name_Id := N + 438;
- Name_Fraction : constant Name_Id := N + 439;
- Name_Image : constant Name_Id := N + 440;
- Name_Input : constant Name_Id := N + 441;
- Name_Machine : constant Name_Id := N + 442;
- Name_Max : constant Name_Id := N + 443;
- Name_Min : constant Name_Id := N + 444;
- Name_Model : constant Name_Id := N + 445;
- Name_Pred : constant Name_Id := N + 446;
- Name_Remainder : constant Name_Id := N + 447;
- Name_Rounding : constant Name_Id := N + 448;
- Name_Succ : constant Name_Id := N + 449;
- Name_Truncation : constant Name_Id := N + 450;
- Name_Value : constant Name_Id := N + 451;
- Name_Wide_Image : constant Name_Id := N + 452;
- Name_Wide_Value : constant Name_Id := N + 453;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 453;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 437;
+ Name_Adjacent : constant Name_Id := N + 437;
+ Name_Ceiling : constant Name_Id := N + 438;
+ Name_Copy_Sign : constant Name_Id := N + 439;
+ Name_Floor : constant Name_Id := N + 440;
+ Name_Fraction : constant Name_Id := N + 441;
+ Name_Image : constant Name_Id := N + 442;
+ Name_Input : constant Name_Id := N + 443;
+ Name_Machine : constant Name_Id := N + 444;
+ Name_Max : constant Name_Id := N + 445;
+ Name_Min : constant Name_Id := N + 446;
+ Name_Model : constant Name_Id := N + 447;
+ Name_Pred : constant Name_Id := N + 448;
+ Name_Remainder : constant Name_Id := N + 449;
+ Name_Rounding : constant Name_Id := N + 450;
+ Name_Succ : constant Name_Id := N + 451;
+ Name_Truncation : constant Name_Id := N + 452;
+ Name_Value : constant Name_Id := N + 453;
+ Name_Wide_Image : constant Name_Id := N + 454;
+ Name_Wide_Value : constant Name_Id := N + 455;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 455;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 454;
- Name_Output : constant Name_Id := N + 454;
- Name_Read : constant Name_Id := N + 455;
- Name_Write : constant Name_Id := N + 456;
- Last_Procedure_Attribute : constant Name_Id := N + 456;
+ First_Procedure_Attribute : constant Name_Id := N + 456;
+ Name_Output : constant Name_Id := N + 456;
+ Name_Read : constant Name_Id := N + 457;
+ Name_Write : constant Name_Id := N + 458;
+ Last_Procedure_Attribute : constant Name_Id := N + 458;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 457;
- Name_Elab_Body : constant Name_Id := N + 457; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 458; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 459;
+ First_Entity_Attribute_Name : constant Name_Id := N + 459;
+ Name_Elab_Body : constant Name_Id := N + 459; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 460; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 461;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 460;
- Name_Base : constant Name_Id := N + 460;
- Name_Class : constant Name_Id := N + 461;
- Last_Type_Attribute_Name : constant Name_Id := N + 461;
- Last_Entity_Attribute_Name : constant Name_Id := N + 461;
- Last_Attribute_Name : constant Name_Id := N + 461;
+ First_Type_Attribute_Name : constant Name_Id := N + 462;
+ Name_Base : constant Name_Id := N + 462;
+ Name_Class : constant Name_Id := N + 463;
+ Last_Type_Attribute_Name : constant Name_Id := N + 463;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 463;
+ Last_Attribute_Name : constant Name_Id := N + 463;
-- Names of recognized locking policy identifiers
-- name (e.g. C for Ceiling_Locking). If new policy names are added,
-- the first character must be distinct.
- First_Locking_Policy_Name : constant Name_Id := N + 462;
- Name_Ceiling_Locking : constant Name_Id := N + 462;
- Name_Inheritance_Locking : constant Name_Id := N + 463;
- Last_Locking_Policy_Name : constant Name_Id := N + 463;
+ First_Locking_Policy_Name : constant Name_Id := N + 464;
+ Name_Ceiling_Locking : constant Name_Id := N + 464;
+ Name_Inheritance_Locking : constant Name_Id := N + 465;
+ Last_Locking_Policy_Name : constant Name_Id := N + 465;
-- Names of recognized queuing policy identifiers.
-- name (e.g. F for FIFO_Queuing). If new policy names are added,
-- the first character must be distinct.
- First_Queuing_Policy_Name : constant Name_Id := N + 464;
- Name_FIFO_Queuing : constant Name_Id := N + 464;
- Name_Priority_Queuing : constant Name_Id := N + 465;
- Last_Queuing_Policy_Name : constant Name_Id := N + 465;
+ First_Queuing_Policy_Name : constant Name_Id := N + 466;
+ Name_FIFO_Queuing : constant Name_Id := N + 466;
+ Name_Priority_Queuing : constant Name_Id := N + 467;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 467;
-- Names of recognized task dispatching policy identifiers
-- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
-- are added, the first character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + 466;
- Name_FIFO_Within_Priorities : constant Name_Id := N + 466;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 466;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 468;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 468;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 468;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 467;
- Name_Access_Check : constant Name_Id := N + 467;
- Name_Accessibility_Check : constant Name_Id := N + 468;
- Name_Discriminant_Check : constant Name_Id := N + 469;
- Name_Division_Check : constant Name_Id := N + 470;
- Name_Elaboration_Check : constant Name_Id := N + 471;
- Name_Index_Check : constant Name_Id := N + 472;
- Name_Length_Check : constant Name_Id := N + 473;
- Name_Overflow_Check : constant Name_Id := N + 474;
- Name_Range_Check : constant Name_Id := N + 475;
- Name_Storage_Check : constant Name_Id := N + 476;
- Name_Tag_Check : constant Name_Id := N + 477;
- Name_All_Checks : constant Name_Id := N + 478;
- Last_Check_Name : constant Name_Id := N + 478;
+ First_Check_Name : constant Name_Id := N + 469;
+ Name_Access_Check : constant Name_Id := N + 469;
+ Name_Accessibility_Check : constant Name_Id := N + 470;
+ Name_Discriminant_Check : constant Name_Id := N + 471;
+ Name_Division_Check : constant Name_Id := N + 472;
+ Name_Elaboration_Check : constant Name_Id := N + 473;
+ Name_Index_Check : constant Name_Id := N + 474;
+ Name_Length_Check : constant Name_Id := N + 475;
+ Name_Overflow_Check : constant Name_Id := N + 476;
+ Name_Range_Check : constant Name_Id := N + 477;
+ Name_Storage_Check : constant Name_Id := N + 478;
+ Name_Tag_Check : constant Name_Id := N + 479;
+ Name_All_Checks : constant Name_Id := N + 480;
+ Last_Check_Name : constant Name_Id := N + 480;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- Name_Abort : constant Name_Id := N + 479;
- Name_Abs : constant Name_Id := N + 480;
- Name_Accept : constant Name_Id := N + 481;
- Name_And : constant Name_Id := N + 482;
- Name_All : constant Name_Id := N + 483;
- Name_Array : constant Name_Id := N + 484;
- Name_At : constant Name_Id := N + 485;
- Name_Begin : constant Name_Id := N + 486;
- Name_Body : constant Name_Id := N + 487;
- Name_Case : constant Name_Id := N + 488;
- Name_Constant : constant Name_Id := N + 489;
- Name_Declare : constant Name_Id := N + 490;
- Name_Delay : constant Name_Id := N + 491;
- Name_Do : constant Name_Id := N + 492;
- Name_Else : constant Name_Id := N + 493;
- Name_Elsif : constant Name_Id := N + 494;
- Name_End : constant Name_Id := N + 495;
- Name_Entry : constant Name_Id := N + 496;
- Name_Exception : constant Name_Id := N + 497;
- Name_Exit : constant Name_Id := N + 498;
- Name_For : constant Name_Id := N + 499;
- Name_Function : constant Name_Id := N + 500;
- Name_Generic : constant Name_Id := N + 501;
- Name_Goto : constant Name_Id := N + 502;
- Name_If : constant Name_Id := N + 503;
- Name_In : constant Name_Id := N + 504;
- Name_Is : constant Name_Id := N + 505;
- Name_Limited : constant Name_Id := N + 506;
- Name_Loop : constant Name_Id := N + 507;
- Name_Mod : constant Name_Id := N + 508;
- Name_New : constant Name_Id := N + 509;
- Name_Not : constant Name_Id := N + 510;
- Name_Null : constant Name_Id := N + 511;
- Name_Of : constant Name_Id := N + 512;
- Name_Or : constant Name_Id := N + 513;
- Name_Others : constant Name_Id := N + 514;
- Name_Out : constant Name_Id := N + 515;
- Name_Package : constant Name_Id := N + 516;
- Name_Pragma : constant Name_Id := N + 517;
- Name_Private : constant Name_Id := N + 518;
- Name_Procedure : constant Name_Id := N + 519;
- Name_Raise : constant Name_Id := N + 520;
- Name_Record : constant Name_Id := N + 521;
- Name_Rem : constant Name_Id := N + 522;
- Name_Renames : constant Name_Id := N + 523;
- Name_Return : constant Name_Id := N + 524;
- Name_Reverse : constant Name_Id := N + 525;
- Name_Select : constant Name_Id := N + 526;
- Name_Separate : constant Name_Id := N + 527;
- Name_Subtype : constant Name_Id := N + 528;
- Name_Task : constant Name_Id := N + 529;
- Name_Terminate : constant Name_Id := N + 530;
- Name_Then : constant Name_Id := N + 531;
- Name_Type : constant Name_Id := N + 532;
- Name_Use : constant Name_Id := N + 533;
- Name_When : constant Name_Id := N + 534;
- Name_While : constant Name_Id := N + 535;
- Name_With : constant Name_Id := N + 536;
- Name_Xor : constant Name_Id := N + 537;
+ Name_Abort : constant Name_Id := N + 481;
+ Name_Abs : constant Name_Id := N + 482;
+ Name_Accept : constant Name_Id := N + 483;
+ Name_And : constant Name_Id := N + 484;
+ Name_All : constant Name_Id := N + 485;
+ Name_Array : constant Name_Id := N + 486;
+ Name_At : constant Name_Id := N + 487;
+ Name_Begin : constant Name_Id := N + 488;
+ Name_Body : constant Name_Id := N + 489;
+ Name_Case : constant Name_Id := N + 490;
+ Name_Constant : constant Name_Id := N + 491;
+ Name_Declare : constant Name_Id := N + 492;
+ Name_Delay : constant Name_Id := N + 493;
+ Name_Do : constant Name_Id := N + 494;
+ Name_Else : constant Name_Id := N + 495;
+ Name_Elsif : constant Name_Id := N + 496;
+ Name_End : constant Name_Id := N + 497;
+ Name_Entry : constant Name_Id := N + 498;
+ Name_Exception : constant Name_Id := N + 499;
+ Name_Exit : constant Name_Id := N + 500;
+ Name_For : constant Name_Id := N + 501;
+ Name_Function : constant Name_Id := N + 502;
+ Name_Generic : constant Name_Id := N + 503;
+ Name_Goto : constant Name_Id := N + 504;
+ Name_If : constant Name_Id := N + 505;
+ Name_In : constant Name_Id := N + 506;
+ Name_Is : constant Name_Id := N + 507;
+ Name_Limited : constant Name_Id := N + 508;
+ Name_Loop : constant Name_Id := N + 509;
+ Name_Mod : constant Name_Id := N + 510;
+ Name_New : constant Name_Id := N + 511;
+ Name_Not : constant Name_Id := N + 512;
+ Name_Null : constant Name_Id := N + 513;
+ Name_Of : constant Name_Id := N + 514;
+ Name_Or : constant Name_Id := N + 515;
+ Name_Others : constant Name_Id := N + 516;
+ Name_Out : constant Name_Id := N + 517;
+ Name_Package : constant Name_Id := N + 518;
+ Name_Pragma : constant Name_Id := N + 519;
+ Name_Private : constant Name_Id := N + 520;
+ Name_Procedure : constant Name_Id := N + 521;
+ Name_Raise : constant Name_Id := N + 522;
+ Name_Record : constant Name_Id := N + 523;
+ Name_Rem : constant Name_Id := N + 524;
+ Name_Renames : constant Name_Id := N + 525;
+ Name_Return : constant Name_Id := N + 526;
+ Name_Reverse : constant Name_Id := N + 527;
+ Name_Select : constant Name_Id := N + 528;
+ Name_Separate : constant Name_Id := N + 529;
+ Name_Subtype : constant Name_Id := N + 530;
+ Name_Task : constant Name_Id := N + 531;
+ Name_Terminate : constant Name_Id := N + 532;
+ Name_Then : constant Name_Id := N + 533;
+ Name_Type : constant Name_Id := N + 534;
+ Name_Use : constant Name_Id := N + 535;
+ Name_When : constant Name_Id := N + 536;
+ Name_While : constant Name_Id := N + 537;
+ Name_With : constant Name_Id := N + 538;
+ Name_Xor : constant Name_Id := N + 539;
-- Names of intrinsic subprograms
-- Note: Asm is missing from this list, since Asm is a legitimate
-- convention name. So is To_Adress, which is a GNAT attribute.
- First_Intrinsic_Name : constant Name_Id := N + 538;
- Name_Divide : constant Name_Id := N + 538;
- Name_Enclosing_Entity : constant Name_Id := N + 539;
- Name_Exception_Information : constant Name_Id := N + 540;
- Name_Exception_Message : constant Name_Id := N + 541;
- Name_Exception_Name : constant Name_Id := N + 542;
- Name_File : constant Name_Id := N + 543;
- Name_Import_Address : constant Name_Id := N + 544;
- Name_Import_Largest_Value : constant Name_Id := N + 545;
- Name_Import_Value : constant Name_Id := N + 546;
- Name_Is_Negative : constant Name_Id := N + 547;
- Name_Line : constant Name_Id := N + 548;
- Name_Rotate_Left : constant Name_Id := N + 549;
- Name_Rotate_Right : constant Name_Id := N + 550;
- Name_Shift_Left : constant Name_Id := N + 551;
- Name_Shift_Right : constant Name_Id := N + 552;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 553;
- Name_Source_Location : constant Name_Id := N + 554;
- Name_Unchecked_Conversion : constant Name_Id := N + 555;
- Name_Unchecked_Deallocation : constant Name_Id := N + 556;
- Name_To_Pointer : constant Name_Id := N + 557;
- Last_Intrinsic_Name : constant Name_Id := N + 557;
+ First_Intrinsic_Name : constant Name_Id := N + 540;
+ Name_Divide : constant Name_Id := N + 540;
+ Name_Enclosing_Entity : constant Name_Id := N + 541;
+ Name_Exception_Information : constant Name_Id := N + 542;
+ Name_Exception_Message : constant Name_Id := N + 543;
+ Name_Exception_Name : constant Name_Id := N + 544;
+ Name_File : constant Name_Id := N + 545;
+ Name_Import_Address : constant Name_Id := N + 546;
+ Name_Import_Largest_Value : constant Name_Id := N + 547;
+ Name_Import_Value : constant Name_Id := N + 548;
+ Name_Is_Negative : constant Name_Id := N + 549;
+ Name_Line : constant Name_Id := N + 550;
+ Name_Rotate_Left : constant Name_Id := N + 551;
+ Name_Rotate_Right : constant Name_Id := N + 552;
+ Name_Shift_Left : constant Name_Id := N + 553;
+ Name_Shift_Right : constant Name_Id := N + 554;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 555;
+ Name_Source_Location : constant Name_Id := N + 556;
+ Name_Unchecked_Conversion : constant Name_Id := N + 557;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 558;
+ Name_To_Pointer : constant Name_Id := N + 559;
+ Last_Intrinsic_Name : constant Name_Id := N + 559;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 558;
- Name_Abstract : constant Name_Id := N + 558;
- Name_Aliased : constant Name_Id := N + 559;
- Name_Protected : constant Name_Id := N + 560;
- Name_Until : constant Name_Id := N + 561;
- Name_Requeue : constant Name_Id := N + 562;
- Name_Tagged : constant Name_Id := N + 563;
- Last_95_Reserved_Word : constant Name_Id := N + 563;
+ First_95_Reserved_Word : constant Name_Id := N + 560;
+ Name_Abstract : constant Name_Id := N + 560;
+ Name_Aliased : constant Name_Id := N + 561;
+ Name_Protected : constant Name_Id := N + 562;
+ Name_Until : constant Name_Id := N + 563;
+ Name_Requeue : constant Name_Id := N + 564;
+ Name_Tagged : constant Name_Id := N + 565;
+ Last_95_Reserved_Word : constant Name_Id := N + 565;
subtype Ada_95_Reserved_Words is
Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
- Name_Raise_Exception : constant Name_Id := N + 564;
+ Name_Raise_Exception : constant Name_Id := N + 566;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Binder : constant Name_Id := N + 565;
- Name_Body_Suffix : constant Name_Id := N + 566;
- Name_Builder : constant Name_Id := N + 567;
- Name_Compiler : constant Name_Id := N + 568;
- Name_Cross_Reference : constant Name_Id := N + 569;
- Name_Default_Switches : constant Name_Id := N + 570;
- Name_Exec_Dir : constant Name_Id := N + 571;
- Name_Executable : constant Name_Id := N + 572;
- Name_Executable_Suffix : constant Name_Id := N + 573;
- Name_Extends : constant Name_Id := N + 574;
- Name_Finder : constant Name_Id := N + 575;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 576;
- Name_Gnatls : constant Name_Id := N + 577;
- Name_Gnatstub : constant Name_Id := N + 578;
- Name_Implementation : constant Name_Id := N + 579;
- Name_Implementation_Exceptions : constant Name_Id := N + 580;
- Name_Implementation_Suffix : constant Name_Id := N + 581;
- Name_Languages : constant Name_Id := N + 582;
- Name_Library_Dir : constant Name_Id := N + 583;
- Name_Library_Auto_Init : constant Name_Id := N + 584;
- Name_Library_GCC : constant Name_Id := N + 585;
- Name_Library_Interface : constant Name_Id := N + 586;
- Name_Library_Kind : constant Name_Id := N + 587;
- Name_Library_Name : constant Name_Id := N + 588;
- Name_Library_Options : constant Name_Id := N + 589;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 590;
- Name_Library_Src_Dir : constant Name_Id := N + 591;
- Name_Library_Symbol_File : constant Name_Id := N + 592;
- Name_Library_Symbol_Policy : constant Name_Id := N + 593;
- Name_Library_Version : constant Name_Id := N + 594;
- Name_Linker : constant Name_Id := N + 595;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 596;
- Name_Locally_Removed_Files : constant Name_Id := N + 597;
- Name_Metrics : constant Name_Id := N + 598;
- Name_Naming : constant Name_Id := N + 599;
- Name_Object_Dir : constant Name_Id := N + 600;
- Name_Pretty_Printer : constant Name_Id := N + 601;
- Name_Project : constant Name_Id := N + 602;
- Name_Separate_Suffix : constant Name_Id := N + 603;
- Name_Source_Dirs : constant Name_Id := N + 604;
- Name_Source_Files : constant Name_Id := N + 605;
- Name_Source_List_File : constant Name_Id := N + 606;
- Name_Spec : constant Name_Id := N + 607;
- Name_Spec_Suffix : constant Name_Id := N + 608;
- Name_Specification : constant Name_Id := N + 609;
- Name_Specification_Exceptions : constant Name_Id := N + 610;
- Name_Specification_Suffix : constant Name_Id := N + 611;
- Name_Switches : constant Name_Id := N + 612;
+ Name_Binder : constant Name_Id := N + 567;
+ Name_Body_Suffix : constant Name_Id := N + 568;
+ Name_Builder : constant Name_Id := N + 569;
+ Name_Compiler : constant Name_Id := N + 570;
+ Name_Cross_Reference : constant Name_Id := N + 571;
+ Name_Default_Switches : constant Name_Id := N + 572;
+ Name_Exec_Dir : constant Name_Id := N + 573;
+ Name_Executable : constant Name_Id := N + 574;
+ Name_Executable_Suffix : constant Name_Id := N + 575;
+ Name_Extends : constant Name_Id := N + 576;
+ Name_Finder : constant Name_Id := N + 577;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 578;
+ Name_Gnatls : constant Name_Id := N + 579;
+ Name_Gnatstub : constant Name_Id := N + 580;
+ Name_Implementation : constant Name_Id := N + 581;
+ Name_Implementation_Exceptions : constant Name_Id := N + 582;
+ Name_Implementation_Suffix : constant Name_Id := N + 583;
+ Name_Languages : constant Name_Id := N + 584;
+ Name_Library_Dir : constant Name_Id := N + 585;
+ Name_Library_Auto_Init : constant Name_Id := N + 586;
+ Name_Library_GCC : constant Name_Id := N + 587;
+ Name_Library_Interface : constant Name_Id := N + 588;
+ Name_Library_Kind : constant Name_Id := N + 589;
+ Name_Library_Name : constant Name_Id := N + 590;
+ Name_Library_Options : constant Name_Id := N + 591;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 592;
+ Name_Library_Src_Dir : constant Name_Id := N + 593;
+ Name_Library_Symbol_File : constant Name_Id := N + 594;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 595;
+ Name_Library_Version : constant Name_Id := N + 596;
+ Name_Linker : constant Name_Id := N + 597;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 598;
+ Name_Locally_Removed_Files : constant Name_Id := N + 599;
+ Name_Metrics : constant Name_Id := N + 600;
+ Name_Naming : constant Name_Id := N + 601;
+ Name_Object_Dir : constant Name_Id := N + 602;
+ Name_Pretty_Printer : constant Name_Id := N + 603;
+ Name_Project : constant Name_Id := N + 604;
+ Name_Separate_Suffix : constant Name_Id := N + 605;
+ Name_Source_Dirs : constant Name_Id := N + 606;
+ Name_Source_Files : constant Name_Id := N + 607;
+ Name_Source_List_File : constant Name_Id := N + 608;
+ Name_Spec : constant Name_Id := N + 609;
+ Name_Spec_Suffix : constant Name_Id := N + 610;
+ Name_Specification : constant Name_Id := N + 611;
+ Name_Specification_Exceptions : constant Name_Id := N + 612;
+ Name_Specification_Suffix : constant Name_Id := N + 613;
+ Name_Switches : constant Name_Id := N + 614;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 613;
+ Name_Unaligned_Valid : constant Name_Id := N + 615;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 613;
+ Last_Predefined_Name : constant Name_Id := N + 615;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
Attribute_First_Bit,
Attribute_Fixed_Value,
Attribute_Fore,
+ Attribute_Has_Access_Values,
Attribute_Has_Discriminants,
Attribute_Identity,
Attribute_Img,
#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 */
Write_Str ("""]");
end Write_Condition_And_Reason;
- ------------------------
- -- Write_Discr_Specs --
- ------------------------
+ -----------------------
+ -- Write_Discr_Specs --
+ -----------------------
procedure Write_Discr_Specs (N : Node_Id) is
- Specs : List_Id;
- Spec : Node_Id;
+ Specs : List_Id;
+ Spec : Node_Id;
begin
Specs := Discriminant_Specifications (N);
-- --
-- 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- --
return N;
end Get_Parent;
- --------------------------------------------
- -- Start of Processing for Get_Unit_Name --
- --------------------------------------------
+ -------------------------------------------
+ -- Start of Processing for Get_Unit_Name --
+ -------------------------------------------
begin
Node := N;
with Gnatvsn;
with Hostparm;
+with Opt;
with Osint; use Osint;
with Ada.Characters.Handling; use Ada.Characters.Handling;
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
raise Normal_Exit;
end if;
- -- Special handling for internal debugging switch /?
+ -- Special handling for internal debugging switch /?
elsif Arg.all = "/?" then
Display_Command := True;
Output_File_Expected := False;
- -- Copy -switch unchanged
+ -- Special handling of internal option /KEEP_TEMPORARY_FILES
+
+ elsif Arg'Length >= 7
+ and then Matching_Name
+ (Arg.all, Keep_Temps_Option, True) /= null
+ then
+ Opt.Keep_Temporary_Files := True;
+
+ -- Copy -switch unchanged
elsif Arg (Arg'First) = '-' then
Place (' ');
type Command_Type is
(Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Pretty, Shared, Stub, Metric, Xref, Undefined);
+ Make, Metric, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined);
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command libel for non VMS system
-- construction of box comments, as shown in
-- the following example:
--
- --
- -- ---------------------------
- -- -- This is a box comment --
- -- -- with two text lines. --
- -- ---------------------------
+ -- ---------------------------
+ -- -- This is a box comment --
+ -- ---------------------------
--
-- END Check end/exit labels.
-- Optional labels on end statements ending
projects / gcc.git / commitdiff