-- --
-- B o d y --
-- --
--- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A CPARTICULAR PURPOSE. See the GNU General Public License --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- Inner_Instances Elist23
-- Enum_Pos_To_Rep Node23
-- Packed_Array_Type Node23
- -- Limited_Views Elist23
+ -- Limited_View Node23
-- Privals_Chain Elist23
-- Protected_Operation Node23
-- Is_CPP_Class Flag74
-- Has_Non_Standard_Rep Flag75
-- Is_Constructor Flag76
+ -- Is_Thread_Body Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Is_Constr_Subt_For_U_Nominal Flag80
-- Is_VMS_Exception Flag133
-- Is_Optional_Parameter Flag134
-- Has_Aliased_Components Flag135
+ -- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
-- Is_Packed_Array_Type Flag138
-- Has_Biased_Representation Flag139
-- Has_Contiguous_Rep Flag181
-- Has_Xref_Entry Flag182
+ -- Must_Be_On_Byte_Boundary Flag183
- -- Remaining flags are currently unused and available
-
- -- (unused) Flag77
- -- (unused) Flag136
- -- (unused) Flag183
+ -- Note: there are no unused flags currently!
--------------------------------
-- Attribute Access Functions --
return Flag55 (Id);
end Is_Tagged_Type;
+ function Is_Thread_Body (Id : E) return B is
+ begin
+ return Flag77 (Id);
+ end Is_Thread_Body;
+
function Is_True_Constant (Id : E) return B is
begin
return Flag163 (Id);
return Node20 (Id);
end Last_Entity;
- function Limited_Views (Id : E) return L is
+ function Limited_View (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
- return Elist23 (Id);
- end Limited_Views;
+ return Node23 (Id);
+ end Limited_View;
function Lit_Indexes (Id : E) return E is
begin
return Uint17 (Base_Type (Id));
end Modulus;
+ function Must_Be_On_Byte_Boundary (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag183 (Id);
+ end Must_Be_On_Byte_Boundary;
+
function Needs_Debug_Info (Id : E) return B is
begin
return Flag147 (Id);
return Flag113 (Id);
end No_Return;
+ function No_Strict_Aliasing (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag136 (Base_Type (Id));
+ end No_Strict_Aliasing;
+
function Non_Binary_Modulus (Id : E) return B is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
return Node17 (Id);
end Object_Ref;
+ function Original_Access_Type (Id : E) return E is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Access_Subprogram_Type
+ or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
+ return Node21 (Id);
+ end Original_Access_Type;
+
function Original_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
+ procedure Set_Is_Thread_Body (Id : E; V : B := True) is
+ begin
+ Set_Flag77 (Id, V);
+ end Set_Is_Thread_Body;
+
procedure Set_Is_True_Constant (Id : E; V : B := True) is
begin
Set_Flag163 (Id, V);
Set_Node20 (Id, V);
end Set_Last_Entity;
- procedure Set_Limited_Views (Id : E; V : L) is
+ procedure Set_Limited_View (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Package);
- Set_Elist23 (Id, V);
- end Set_Limited_Views;
+ Set_Node23 (Id, V);
+ end Set_Limited_View;
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
Set_Uint17 (Id, V);
end Set_Modulus;
+ procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag183 (Id, V);
+ end Set_Must_Be_On_Byte_Boundary;
+
procedure Set_Needs_Debug_Info (Id : E; V : B := True) is
begin
Set_Flag147 (Id, V);
Set_Flag113 (Id, V);
end Set_No_Return;
+ procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
+ Set_Flag136 (Id, V);
+ end Set_No_Strict_Aliasing;
+
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
Set_Node17 (Id, V);
end Set_Object_Ref;
+ procedure Set_Original_Access_Type (Id : E; V : E) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Access_Subprogram_Type
+ or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
+ Set_Node21 (Id, V);
+ end Set_Original_Access_Type;
+
procedure Set_Original_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
S : Entity_Id;
begin
+ -- The following test is an error defense against some syntax
+ -- errors that can leave scopes very messed up.
+
+ if Id = Standard_Standard then
+ return Id;
+ end if;
+
+ -- Normal case, search enclosing scopes
+
S := Scope (Id);
while S /= Standard_Standard
and then not Is_Dynamic_Scope (S)
end Entry_Index_Type;
---------------------
- -- First_Component --
+ -- 1 --
---------------------
function First_Component (Id : E) return E is
(Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
Comp_Id := First_Entity (Id);
-
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
+ W ("Is_Thread_Body", Flag77 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
W ("Kill_Tag_Checks", Flag34 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id));
+ W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
W ("Never_Set_In_Source", Flag115 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
W ("No_Return", Flag113 (Id));
+ W ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
W ("Reachable", Flag49 (Id));
Modular_Integer_Kind =>
Write_Str ("Original_Array_Type");
+ when E_Access_Subprogram_Type |
+ E_Access_Protected_Subprogram_Type =>
+ Write_Str ("Original_Access_Type");
+
when others =>
Write_Str ("Field21??");
end case;
OSDN Git Service
