Nodes_Initial : constant := 50_000; -- Atree
Nodes_Increment : constant := 100;
+ Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag
+ Obsolescent_Warnings_Increment : constant := 200;
+
Orig_Nodes_Initial : constant := 50_000; -- Atree
Orig_Nodes_Increment : constant := 100;
-- Homonym Node4
-- First_Rep_Item Node6
-- Freeze_Node Node7
- -- Obsolescent_Warning Node24
-- The usage of other fields (and the entity kinds to which it applies)
-- depends on the particular field (see Einfo spec for details).
-- Master_Id Node17
-- Modulus Uint17
-- Non_Limited_View Node17
- -- Object_Ref Node17
-- Prival Node17
-- Alias Node18
-- Discriminant_Checking_Func Node20
-- Discriminant_Default_Value Node20
-- Last_Entity Node20
+ -- Prival_Link Node20
-- Register_Exception_Call Node20
-- Scalar_Range Node20
-- Associated_Final_Chain Node23
-- CR_Discriminant Node23
- -- Stored_Constraint Elist23
-- Entry_Cancel_Parameter Node23
+ -- Enum_Pos_To_Rep Node23
-- Extra_Constrained Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
- -- Enum_Pos_To_Rep Node23
- -- Packed_Array_Type Node23
-- Limited_View Node23
- -- Privals_Chain Elist23
- -- Protected_Operation Node23
+ -- Packed_Array_Type Node23
+ -- Protection_Object Node23
+ -- Stored_Constraint Elist23
- -- Obsolescent_Warning Node24
+ -- Spec_PPC_List Node24
-- Abstract_Interface_Alias Node25
-- Abstract_Interfaces Elist25
- -- Current_Use_Clause Node25
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Related_Type Node26
+ -- Relative_Deadline_Variable Node26
-- Static_Initialization Node26
+ -- Current_Use_Clause Node27
-- Wrapped_Entity Node27
-- Extra_Formals Node28
-- Renamed_In_Spec Flag231
-- Implemented_By_Entry Flag232
-- Has_Pragma_Unmodified Flag233
- -- Is_Static_Dispatch_Table_Entity Flag234
+ -- Is_Dispatch_Table_Entity Flag234
-- Is_Trivial_Subprogram Flag235
-- Warnings_Off_Used Flag236
-- Warnings_Off_Used_Unmodified Flag237
-- Warnings_Off_Used_Unreferenced Flag238
-- OK_To_Reorder_Components Flag239
+ -- Has_Postconditions Flag240
+
+ -- Optimize_Alignment_Space Flag241
+ -- Optimize_Alignment_Time Flag242
+ -- Overlays_Constant Flag243
- -- (unused) Flag240
- -- (unused) Flag241
- -- (unused) Flag242
- -- (unused) Flag243
-- (unused) Flag244
-- (unused) Flag245
-- (unused) Flag246
function Current_Use_Clause (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Package);
- return Node25 (Id);
+ pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id));
+ return Node27 (Id);
end Current_Use_Clause;
function Current_Value (Id : E) return N is
function Can_Use_Internal_Rep (Id : E) return B is
begin
- pragma Assert (Is_Access_Subprogram_Type (Id));
- return Flag229 (Id);
+ pragma Assert (Is_Access_Subprogram_Type (Base_Type (Id)));
+ return Flag229 (Base_Type (Id));
end Can_Use_Internal_Rep;
function Finalization_Chain_Entity (Id : E) return E is
return Flag188 (Id);
end Has_Persistent_BSS;
+ function Has_Postconditions (Id : E) return B is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Flag240 (Id);
+ end Has_Postconditions;
+
function Has_Pragma_Controlled (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag74 (Id);
end Is_CPP_Class;
+ function Is_Descendent_Of_Address (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag223 (Id);
+ end Is_Descendent_Of_Address;
+
function Is_Discrim_SO_Function (Id : E) return B is
begin
return Flag176 (Id);
end Is_Discrim_SO_Function;
- function Is_Descendent_Of_Address (Id : E) return B is
+ function Is_Dispatch_Table_Entity (Id : E) return B is
begin
- pragma Assert (Is_Type (Id));
- return Flag223 (Id);
- end Is_Descendent_Of_Address;
+ return Flag234 (Id);
+ end Is_Dispatch_Table_Entity;
function Is_Dispatching_Operation (Id : E) return B is
begin
return Flag28 (Id);
end Is_Statically_Allocated;
- function Is_Static_Dispatch_Table_Entity (Id : E) return B is
- begin
- return Flag234 (Id);
- end Is_Static_Dispatch_Table_Entity;
-
function Is_Synchronized_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
return Uint10 (Id);
end Normalized_Position_Max;
- function Object_Ref (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Protected_Body);
- return Node17 (Id);
- end Object_Ref;
-
- function Obsolescent_Warning (Id : E) return N is
- begin
- return Node24 (Id);
- end Obsolescent_Warning;
-
function OK_To_Reorder_Components (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
return Flag239 (Base_Type (Id));
end OK_To_Reorder_Components;
+ function Optimize_Alignment_Space (Id : E) return B is
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ return Flag241 (Id);
+ end Optimize_Alignment_Space;
+
+ function Optimize_Alignment_Time (Id : E) return B is
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ return Flag242 (Id);
+ end Optimize_Alignment_Time;
+
function Original_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
return Node22 (Id);
end Original_Record_Component;
+ function Overlays_Constant (Id : E) return B is
+ begin
+ return Flag243 (Id);
+ end Overlays_Constant;
+
function Overridden_Operation (Id : E) return E is
begin
return Node26 (Id);
function Prival (Id : E) return E is
begin
- pragma Assert (Is_Protected_Private (Id));
+ pragma Assert (Is_Protected_Component (Id));
return Node17 (Id);
end Prival;
- function Privals_Chain (Id : E) return L is
+ function Prival_Link (Id : E) return E is
begin
- pragma Assert (Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family);
- return Elist23 (Id);
- end Privals_Chain;
+ pragma Assert (Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ return Node20 (Id);
+ end Prival_Link;
function Private_Dependents (Id : E) return L is
begin
return Node22 (Id);
end Protected_Formal;
- function Protected_Operation (Id : E) return N is
+ function Protection_Object (Id : E) return E is
begin
- pragma Assert (Is_Protected_Private (Id));
+ pragma Assert (Ekind (Id) = E_Entry
+ or else Ekind (Id) = E_Entry_Family
+ or else Ekind (Id) = E_Function
+ or else Ekind (Id) = E_Procedure);
return Node23 (Id);
- end Protected_Operation;
+ end Protection_Object;
function Reachable (Id : E) return B is
begin
return Node26 (Id);
end Related_Type;
+ function Relative_Deadline_Variable (Id : E) return E is
+ begin
+ pragma Assert (Is_Task_Type (Id));
+ return Node26 (Implementation_Base_Type (Id));
+ end Relative_Deadline_Variable;
+
function Renamed_Entity (Id : E) return N is
begin
return Node18 (Id);
return Node19 (Id);
end Spec_Entity;
+ function Spec_PPC_List (Id : E) return N is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Node24 (Id);
+ end Spec_PPC_List;
+
function Storage_Size_Variable (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
procedure Set_Current_Use_Clause (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Package);
- Set_Node25 (Id, V);
+ pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id));
+ Set_Node27 (Id, V);
end Set_Current_Use_Clause;
procedure Set_Current_Value (Id : E; V : N) is
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Subprogram_Type (Id));
+ pragma Assert
+ (Is_Access_Subprogram_Type (Id)
+ and then Id = Base_Type (Id));
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
procedure Set_Has_Aliased_Components (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag135 (Id, V);
end Set_Has_Aliased_Components;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id);
+ pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
Set_Flag86 (Id, V);
end Set_Has_Atomic_Components;
procedure Set_Has_Biased_Representation (Id : E; V : B := True) is
begin
pragma Assert
- ((V = False) or else (Is_Discrete_Type (Id) or Is_Object (Id)));
+ ((V = False) or else (Is_Discrete_Type (Id) or else Is_Object (Id)));
Set_Flag139 (Id, V);
end Set_Has_Biased_Representation;
procedure Set_Has_Controlled_Component (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag43 (Id, V);
end Set_Has_Controlled_Component;
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag75 (Id, V);
end Set_Has_Non_Standard_Rep;
Set_Flag188 (Id, V);
end Set_Has_Persistent_BSS;
+ procedure Set_Has_Postconditions (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Flag240 (Id, V);
+ end Set_Has_Postconditions;
+
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag23 (Id, V);
end Set_Has_Storage_Size_Clause;
procedure Set_Has_Task (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag30 (Id, V);
end Set_Has_Task;
procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag123 (Id, V);
end Set_Has_Unchecked_Union;
procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id);
+ pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
Set_Flag176 (Id, V);
end Set_Is_Discrim_SO_Function;
+ procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True) is
+ begin
+ Set_Flag234 (Id, V);
+ end Set_Is_Dispatch_Table_Entity;
+
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is
begin
pragma Assert
procedure Set_Is_Packed (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag51 (Id, V);
end Set_Is_Packed;
Set_Flag28 (Id, V);
end Set_Is_Statically_Allocated;
- procedure Set_Is_Static_Dispatch_Table_Entity (Id : E; V : B := True) is
- begin
- Set_Flag234 (Id, V);
- end Set_Is_Static_Dispatch_Table_Entity;
-
procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag117 (Id, V);
end Set_Is_Unchecked_Union;
procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
+ pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
Set_Flag131 (Id, V);
end Set_No_Pool_Assigned;
procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
+ pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
Set_Flag136 (Id, V);
end Set_No_Strict_Aliasing;
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
- procedure Set_Object_Ref (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Protected_Body);
- Set_Node17 (Id, V);
- end Set_Object_Ref;
-
- procedure Set_Obsolescent_Warning (Id : E; V : N) is
- begin
- Set_Node24 (Id, V);
- end Set_Obsolescent_Warning;
-
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is
begin
pragma Assert
Set_Flag239 (Id, V);
end Set_OK_To_Reorder_Components;
+ procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ Set_Flag241 (Id, V);
+ end Set_Optimize_Alignment_Space;
+
+ procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ Set_Flag242 (Id, V);
+ end Set_Optimize_Alignment_Time;
+
procedure Set_Original_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
Set_Node22 (Id, V);
end Set_Original_Record_Component;
+ procedure Set_Overlays_Constant (Id : E; V : B := True) is
+ begin
+ Set_Flag243 (Id, V);
+ end Set_Overlays_Constant;
+
procedure Set_Overridden_Operation (Id : E; V : E) is
begin
Set_Node26 (Id, V);
procedure Set_Prival (Id : E; V : E) is
begin
- pragma Assert (Is_Protected_Private (Id));
+ pragma Assert (Is_Protected_Component (Id));
Set_Node17 (Id, V);
end Set_Prival;
- procedure Set_Privals_Chain (Id : E; V : L) is
+ procedure Set_Prival_Link (Id : E; V : E) is
begin
- pragma Assert (Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family);
- Set_Elist23 (Id, V);
- end Set_Privals_Chain;
+ pragma Assert (Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable);
+ Set_Node20 (Id, V);
+ end Set_Prival_Link;
procedure Set_Private_Dependents (Id : E; V : L) is
begin
Set_Node22 (Id, V);
end Set_Protected_Formal;
- procedure Set_Protected_Operation (Id : E; V : N) is
+ procedure Set_Protection_Object (Id : E; V : E) is
begin
- pragma Assert (Is_Protected_Private (Id));
+ pragma Assert (Ekind (Id) = E_Entry
+ or else Ekind (Id) = E_Entry_Family
+ or else Ekind (Id) = E_Function
+ or else Ekind (Id) = E_Procedure);
Set_Node23 (Id, V);
- end Set_Protected_Operation;
+ end Set_Protection_Object;
procedure Set_Reachable (Id : E; V : B := True) is
begin
Set_Node26 (Id, V);
end Set_Related_Type;
+ procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id));
+ Set_Node26 (Id, V);
+ end Set_Relative_Deadline_Variable;
+
procedure Set_Renamed_Entity (Id : E; V : N) is
begin
Set_Node18 (Id, V);
Set_Node19 (Id, V);
end Set_Spec_Entity;
+ procedure Set_Spec_PPC_List (Id : E; V : N) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Node24 (Id, V);
+ end Set_Spec_PPC_List;
+
procedure Set_Storage_Size_Variable (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Node15 (Id, V);
end Set_Storage_Size_Variable;
procedure Set_Strict_Alignment (Id : E; V : B := True) is
begin
- pragma Assert (Base_Type (Id) = Id);
+ pragma Assert (Id = Base_Type (Id));
Set_Flag145 (Id, V);
end Set_Strict_Alignment;
procedure Set_Universal_Aliasing (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Base_Type (Id) = Id);
+ pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
Set_Flag216 (Id, V);
end Set_Universal_Aliasing;
procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is
begin
if Last_Entity (V) = Empty then
- Set_First_Entity (V, Id);
+ Set_First_Entity (Id => V, V => Id);
else
Set_Next_Entity (Last_Entity (V), Id);
end if;
Set_Next_Entity (Id, Empty);
Set_Scope (Id, V);
- Set_Last_Entity (V, Id);
+ Set_Last_Entity (Id => V, V => Id);
end Append_Entity;
--------------------
S := Scope (S);
end if;
end loop;
-
- return S;
end Enclosing_Dynamic_Scope;
----------------------
end if;
end Is_By_Reference_Type;
+ ------------------------
+ -- Is_Constant_Object --
+ ------------------------
+
+ function Is_Constant_Object (Id : E) return B is
+ K : constant Entity_Kind := Ekind (Id);
+ begin
+ return
+ K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter;
+ end Is_Constant_Object;
+
---------------------
-- Is_Derived_Type --
---------------------
return Present (Par)
and then Nkind (Par) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Par))
- = N_Derived_Type_Definition;
+ and then Nkind (Type_Definition (Par)) =
+ N_Derived_Type_Definition;
end if;
else
end if;
end Is_Derived_Type;
+ --------------------
+ -- Is_Discriminal --
+ --------------------
+
+ function Is_Discriminal (Id : E) return B is
+ begin
+ return
+ (Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_In_Parameter)
+ and then Present (Discriminal_Link (Id));
+ end Is_Discriminal;
+
----------------------
-- Is_Dynamic_Scope --
----------------------
end if;
end Is_Indefinite_Subtype;
+ --------------------------------
+ -- Is_Inherently_Limited_Type --
+ --------------------------------
+
+ function Is_Inherently_Limited_Type (Id : E) return B is
+ Btype : constant Entity_Id := Base_Type (Id);
+
+ begin
+ if Is_Private_Type (Btype) then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (Utyp) then
+ return False;
+ else
+ return Is_Inherently_Limited_Type (Utyp);
+ end if;
+ end;
+
+ elsif Is_Concurrent_Type (Btype) then
+ return True;
+
+ elsif Is_Record_Type (Btype) then
+ if Is_Limited_Record (Btype) then
+ return not Is_Interface (Btype)
+ or else Is_Protected_Interface (Btype)
+ or else Is_Synchronized_Interface (Btype)
+ or else Is_Task_Interface (Btype);
+
+ elsif Is_Class_Wide_Type (Btype) then
+ return Is_Inherently_Limited_Type (Root_Type (Btype));
+
+ else
+ declare
+ C : Entity_Id;
+
+ begin
+ C := First_Component (Btype);
+ while Present (C) loop
+ if Is_Inherently_Limited_Type (Etype (C)) then
+ return True;
+ end if;
+
+ C := Next_Component (C);
+ end loop;
+ end;
+
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Btype) then
+ return Is_Inherently_Limited_Type (Component_Type (Btype));
+
+ else
+ return False;
+ end if;
+ end Is_Inherently_Limited_Type;
+
---------------------
-- Is_Limited_Type --
---------------------
Ekind (Id) = E_Generic_Package;
end Is_Package_Or_Generic_Package;
- --------------------------
- -- Is_Protected_Private --
- --------------------------
+ ---------------
+ -- Is_Prival --
+ ---------------
- function Is_Protected_Private (Id : E) return B is
+ function Is_Prival (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Component);
- return Is_Protected_Type (Scope (Id));
- end Is_Protected_Private;
+ return
+ (Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Variable)
+ and then Present (Prival_Link (Id));
+ end Is_Prival;
+
+ ----------------------------
+ -- Is_Protected_Component --
+ ----------------------------
+
+ function Is_Protected_Component (Id : E) return B is
+ begin
+ return Ekind (Id) = E_Component
+ and then Is_Protected_Type (Scope (Id));
+ end Is_Protected_Component;
------------------------------
-- Is_Protected_Record_Type --
end Is_Protected_Record_Type;
--------------------------------
- -- Is_Inherently_Limited_Type --
+ -- Is_Standard_Character_Type --
--------------------------------
- function Is_Inherently_Limited_Type (Id : E) return B is
- Btype : constant Entity_Id := Base_Type (Id);
-
+ function Is_Standard_Character_Type (Id : E) return B is
begin
- if Is_Private_Type (Btype) then
+ if Is_Type (Id) then
declare
- Utyp : constant Entity_Id := Underlying_Type (Btype);
+ R : constant Entity_Id := Root_Type (Id);
begin
- if No (Utyp) then
- return False;
- else
- return Is_Inherently_Limited_Type (Utyp);
- end if;
+ return
+ R = Standard_Character
+ or else
+ R = Standard_Wide_Character
+ or else
+ R = Standard_Wide_Wide_Character;
end;
- elsif Is_Concurrent_Type (Btype) then
- return True;
-
- elsif Is_Record_Type (Btype) then
- if Is_Limited_Record (Btype) then
- return not Is_Interface (Btype)
- or else Is_Protected_Interface (Btype)
- or else Is_Synchronized_Interface (Btype)
- or else Is_Task_Interface (Btype);
-
- elsif Is_Class_Wide_Type (Btype) then
- return Is_Inherently_Limited_Type (Root_Type (Btype));
-
- else
- declare
- C : Entity_Id;
-
- begin
- C := First_Component (Btype);
- while Present (C) loop
- if Is_Inherently_Limited_Type (Etype (C)) then
- return True;
- end if;
-
- C := Next_Component (C);
- end loop;
- end;
-
- return False;
- end if;
-
- elsif Is_Array_Type (Btype) then
- return Is_Inherently_Limited_Type (Component_Type (Btype));
-
else
return False;
end if;
- end Is_Inherently_Limited_Type;
+ end Is_Standard_Character_Type;
--------------------
-- Is_String_Type --
T := Etyp;
- -- Return if there is a circularity in the inheritance chain.
- -- This happens in some error situations and we do not want
- -- to get stuck in this loop.
+ -- Return if there is a circularity in the inheritance chain. This
+ -- happens in some error situations and we do not want to get
+ -- stuck in this loop.
if T = Base_Type (Id) then
return T;
end if;
end loop;
end if;
-
- raise Program_Error;
end Root_Type;
-----------------
begin
if (Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Base_Type (Id) = Id
+ and then Id = Base_Type (Id)
then
Write_Str (Prefix);
Write_Str ("Component_Alignment = ");
W ("Has_Object_Size_Clause", Flag172 (Id));
W ("Has_Per_Object_Constraint", Flag154 (Id));
W ("Has_Persistent_BSS", Flag188 (Id));
+ W ("Has_Postconditions", Flag240 (Id));
W ("Has_Pragma_Controlled", Flag27 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
W ("Is_Descendent_Of_Address", Flag223 (Id));
W ("Is_Discrim_SO_Function", Flag176 (Id));
+ W ("Is_Dispatch_Table_Entity", Flag234 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Return_Object", Flag209 (Id));
W ("Is_Shared_Passive", Flag60 (Id));
W ("Is_Synchronized_Interface", Flag199 (Id));
- W ("Is_Static_Dispatch_Table_Entity", Flag234 (Id));
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
W ("OK_To_Reorder_Components", Flag239 (Id));
+ W ("Optimize_Alignment_Space", Flag241 (Id));
+ W ("Optimize_Alignment_Time", Flag242 (Id));
+ W ("Overlays_Constant", Flag243 (Id));
W ("Reachable", Flag49 (Id));
W ("Referenced", Flag156 (Id));
W ("Referenced_As_LHS", Flag36 (Id));
when Array_Kind =>
Write_Str ("First_Index");
- when E_Protected_Body =>
- Write_Str ("Object_Ref");
-
when Enumeration_Kind =>
Write_Str ("First_Literal");
when E_Component =>
Write_Str ("Discriminant_Checking_Func");
+ when E_Constant |
+ E_Variable =>
+ Write_Str ("Prival_Link");
+
when E_Discriminant =>
Write_Str ("Discriminant_Default_Value");
when E_Block =>
Write_Str ("Entry_Cancel_Parameter");
- when E_Component =>
- Write_Str ("Protected_Operation");
-
when E_Discriminant =>
Write_Str ("CR_Discriminant");
when E_Function |
E_Procedure =>
- Write_Str ("Generic_Renamings");
+ if Present (Scope (Id))
+ and then Is_Protected_Type (Scope (Id))
+ then
+ Write_Str ("Protection_Object");
+ else
+ Write_Str ("Generic_Renamings");
+ end if;
when E_Package =>
if Is_Generic_Instance (Id) then
Write_Str ("Limited_View");
end if;
- -- What about Privals_Chain for protected operations ???
-
when Entry_Kind =>
- Write_Str ("Privals_Chain");
+ Write_Str ("Protection_Object");
when others =>
Write_Str ("Field23??");
------------------------
procedure Write_Field24_Name (Id : Entity_Id) is
- pragma Warnings (Off, Id);
begin
- Write_Str ("Obsolescent_Warning");
+ case Ekind (Id) is
+ when Subprogram_Kind =>
+ Write_Str ("Spec_PPC_List");
+
+ when others =>
+ Write_Str ("???");
+ end case;
end Write_Field24_Name;
------------------------
E_Function =>
Write_Str ("Abstract_Interface_Alias");
- when E_Package =>
- Write_Str ("Current_Use_Clause");
-
when E_Record_Type |
E_Record_Subtype |
E_Record_Type_With_Private |
E_Variable =>
Write_Str ("Last_Assignment");
+ when Task_Kind =>
+ Write_Str ("Relative_Deadline_Variable");
+
when others =>
Write_Str ("Field26??");
end case;
when E_Procedure =>
Write_Str ("Wrapped_Entity");
+ when E_Package | Type_Kind =>
+ Write_Str ("Current_Use_Clause");
+
when others =>
Write_Str ("Field27??");
end case;
-- attribute on other than the base type, and if assertions are enabled,
-- an attempt to set the attribute on a subtype will raise an assert error.
--- Other attributes are noted as applying the implementation base type only.
--- These are representation attributes which must always apply to a full
--- non-private type, and where the attributes are always on the full type.
--- The attribute can be referenced on a subtype (and automatically retries
--- the value from the implementation base type). However, it is an error
--- to try to set the attribute on other than the implementation base type,
--- and if assertions are enabled, an attempt to set the attribute on a
+-- Other attributes are noted as applying to the [implementation base type
+-- only]. These are representation attributes which must always apply to a
+-- full non-private type, and where the attributes are always on the full
+-- type. The attribute can be referenced on a subtype (and automatically
+-- retries the value from the implementation base type). However, it is an
+-- error to try to set the attribute on other than the implementation base
+-- type, and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
-- Abstract_Interfaces (Elist25)
-- created at the same time as the discriminal, and used to replace
-- occurrences of the discriminant within the type declaration.
--- Current_Use_Clause (Node25)
--- Present in packages. Indicates the use clause currently in scope
--- that makes the package use_visible. Used to detect redundant use
--- clauses for the same package.
+-- Current_Use_Clause (Node27)
+-- Present in packages and in types. For packages, denotes the use
+-- package clause currently in scope that makes the package use_visible.
+-- For types, it denotes the use_type clause that makes the operators of
+-- the type visible. Used for more precise warning messages on redundant
+-- use clauses.
-- Current_Value (Node9)
-- Present in all object entities. Set in E_Variable, E_Constant, formal
-- Equivalent_Type (Node18)
-- Present in class wide types and subtypes, access to protected
--- subprogram types, and in exception_types. For a classwide type, it
+-- subprogram types, and in exception types. For a classwide type, it
-- is always Empty. For a class wide subtype, it points to an entity
-- created by the expander which gives Gigi an easily understandable
-- equivalent of the class subtype with a known size (given by an
-- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further
--- details. For E_exception_type, this points to the record containing
+-- details. For E_Exception_Type, this points to the record containing
-- the data necessary to represent exceptions (for further details, see
-- System.Standard_Library. For access_to_protected subprograms, it
-- denotes a record that holds pointers to the operation and to the
-- must be retrieved through the entity designed by this field instead of
-- being computed.
--- Can_Use_Internal_Rep (Flag229)
+-- Can_Use_Internal_Rep (Flag229) [base type only]
-- Present in Access_Subprogram_Kind nodes. This flag is set by the
-- front end and used by the back end. False means that the back end
-- must represent the type in the same way as Convention-C types (and
-- error exeption is correctly raised in this case at runtime.
-- Has_Up_Level_Access (Flag215)
--- Present in E_Variable and E_Constant entities. Set if the entity is
--- declared in a local procedure p and is accessed in a procedure nested
--- inside p. Only set when VM_Target /= No_VM currently.
--- Why only set it under those conditions, sounds reasonable to always
--- set this flag when appropriate ???
+-- Present in E_Variable and E_Constant entities. Set if the entity
+-- is a local variable declared in a subprogram p and is accessed in
+-- a subprogram nested inside p. Currently this flag is only set when
+-- VM_Target /= No_VM, for efficiency, since only the .NET back-end
+-- makes use of it to generate proper code for up-level references.
-- Has_Nested_Block_With_Handler (Flag101)
-- Present in scope entities. Set if there is a nested block within the
-- to which the pragma applies, as well as the unit entity itself, for
-- convenience in propagating the flag to contained entities.
+-- Has_Postconditions (Flag240)
+-- Present in subprogram entities. Set if postconditions are active for
+-- the procedure, and a _postconditions procedure has been generated.
+
-- Has_Pragma_Controlled (Flag27) [implementation base type only]
-- Present in access type entities. It is set if a pragma Controlled
-- applies to the access type.
-- Applies to all entities, true for task types and subtypes and for
-- protected types and subtypes.
+-- Is_Constant_Object (synthesized)
+-- Applies to all entities, true for E_Constant, E_Loop_Parameter, and
+-- E_In_Parameter entities.
+
-- Is_Constrained (Flag12)
-- Present in types or subtypes which may have index, discriminant
-- or range constraint (i.e. array types and subtypes, record types
-- Present in all entities. Set only in E_Function entities that Layout
-- creates to compute discriminant-dependent dynamic size/offset values.
+-- Is_Discriminal (synthesized)
+-- Applies to all entities, true for renamings of discriminants. Such
+-- entities appear as constants or in parameters.
+
+-- Is_Dispatch_Table_Entity (Flag234)
+-- Applies to all entities. Set to indicate to the backend that this
+-- entity is associated with a dispatch table.
+
-- Is_Dispatching_Operation (Flag6)
-- Present in all entities. Set true for procedures, functions,
-- generic procedures and generic functions if the corresponding
-- primitive wrappers. which are generated by the expander to wrap
-- entries of protected or task types implementing a limited interface.
+-- Is_Prival (synthesized)
+-- Applies to all entities, true for renamings of private protected
+-- components. Such entities appear as constants or variables.
+
-- Is_Private_Composite (Flag107)
-- Present in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes
+-- Is_Protected_Component (synthesized)
+-- Applicable to all entities, true if the entity denotes a private
+-- component of a protected type.
+
-- Is_Protected_Interface (Flag198)
-- Present in types that are interfaces. True if interface is declared
-- protected, or is derived from protected interfaces.
-- example in the case of a variable name, then Gigi will generate an
-- appropriate external name for use by the linker.
--- Is_Protected_Private (synthesized)
--- Applies to a record component. Returns true if this component
--- is used to represent a private declaration of a protected type.
-
-- Is_Protected_Record_Type (synthesized)
-- Applies to all entities, true if Is_Concurrent_Record_Type
-- Corresponding_Concurrent_Type is a protected type.
-- freeze time if the access type has a storage pool.
-- Is_Raised (Flag224)
--- Present in entities which denote exceptions. Set if the exception is
--- thrown by a raise statement.
+-- Present in exception entities. Set if the entity is referenced by a
+-- a raise statement.
-- Is_Real_Type (synthesized)
-- Applies to all entities, true for real types and subtypes
-- entities to which a pragma Shared_Passive is applied, and also in
-- all entities within such packages.
+-- Is_Standard_Character_Type (synthesized)
+-- Applies to all entities, true for types and subtypes whose root type
+-- is one of the standard character types (Character, Wide_Character,
+-- Wide_Wide_Character).
+
-- Is_Statically_Allocated (Flag28)
-- Present in all entities. This can only be set True for exception,
-- variable, constant, and type/subtype entities. If the flag is set,
-- flag set (since to allocate the object statically, its type must
-- also be elaborated globally).
--- Is_Static_Dispatch_Table_Entity (Flag234)
--- Applies to all entities. Set to indicate to the backend that this
--- entity is associated with an statically allocated dispatch table.
-
--- Is_Subprogram (synthesized)
--- Applies to all entities, true for function, procedure and operator
--- entities.
-
-- Is_String_Type (synthesized)
-- Applies to all type entities. Determines if the given type is a
-- string type, i.e. it is directly a string type or string subtype,
-- or a string slice type, or an array type with one dimension and a
-- component type that is a character type.
+-- Is_Subprogram (synthesized)
+-- Applies to all entities, true for function, procedure and operator
+-- entities.
+
-- Is_Synchronized_Interface (Flag199)
-- Present in types that are interfaces. True if interface is declared
-- synchronized, task, or protected, or is derived from a synchronized
-- Is_Tag (Flag78)
-- Present in E_Component and E_Constant entities. For regular tagged
--- type this flag is set on the tag component (whose name is Name_uTag)
--- and for CPP_Class tagged types, this flag marks the pointer to the
--- main vtable (i.e. the one to be extended by derivation).
+-- type this flag is set on the tag component (whose name is Name_uTag).
+-- For CPP_Class tagged types, this flag marks the pointer to the main
+-- vtable (i.e. the one to be extended by derivation).
-- Is_Tagged_Type (Flag55)
-- Present in all entities. Set for an entity for a tagged type.
-- Is_Task_Interface (Flag200)
--- Present in types that are interfaces. True is interface is declared
--- as such, or if it is derived from task interfaces.
+-- Present in types that are interfaces. True if interface is declared as
+-- a task interface, or if it is derived from task interfaces.
-- Is_Task_Record_Type (synthesized)
-- Applies to all entities. True if Is_Concurrent_Record_Type
-- Applies to subprograms and subprogram types. Yields the number of
-- formals as a value of type Pos.
--- Obsolescent_Warning (Node24)
--- Present in all entities. Set non-empty only if a pragma Obsolescent
--- applying to the entity had a string argument, in which case it records
--- the contents of the corresponding string literal node. This field is
--- only accessed if the flag Is_Obsolescent is set.
+-- Optimize_Alignment_Space (Flag241)
+-- A flag present in type, subtype, variable, and constant entities. This
+-- flag records that the type or object is to be layed out in a manner
+-- consistent with Optimize_Alignment (Space) mode. The compiler and
+-- binder ensure a consistent view of any given type or object. If pragma
+-- Optimize_Alignment (Off) mode applies to the type/object, then neither
+-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
+
+-- Optimize_Alignment_Time (Flag242)
+-- A flag present in type, subtype, variable, and constant entities. This
+-- flag records that the type or object is to be layed out in a manner
+-- consistent with Optimize_Alignment (Time) mode. The compiler and
+-- binder ensure a consistent view of any given type or object. If pragma
+-- Optimize_Alignment (Off) mode applies to the type/object, then neither
+-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set.
-- Original_Array_Type (Node21)
-- Present in modular types and array types and subtypes. Set only
-- points to the original array type for which this is the packed
-- array implementation type.
--- Object_Ref (Node17)
--- Present in protected bodies. This is an implicit prival for the
--- Protection object associated with a protected object. See Prival
--- for further details on the use of privals.
-
-- OK_To_Reorder_Components (Flag239) [base type only]
-- Present in record types. Set if the back end is permitted to reorder
-- the components. If not set, the record must be layed out in the order
-- In subtypes (tagged and untagged):
-- Points to the component in the base type.
+-- Overlays_Constant (Flag243)
+-- Present in all entities. Set only for a variable for which there is
+-- an address clause which causes the variable to overlay a constant.
+
-- Overridden_Operation (Node26)
-- Present in subprograms. For overriding operations, points to the
-- user-defined parent subprogram that is being overridden.
-- is an error to reference the primitive operations field of a type
-- that is not tagged).
+-- Prival (Node17)
+-- Present in private components of protected types. Refers to the entity
+-- of the component renaming declaration generated inside protected
+-- subprograms, entries or barrier functions.
+
+-- Prival_Link (Node20)
+-- Present in constants and variables which rename private components of
+-- protected types. Set to the original private component.
+
-- Private_Dependents (Elist18)
-- Present in private (sub)types. Records the subtypes of the
-- private type, derivations from it, and records and arrays
-- declaration of the type is seen. Subprograms that have such an
-- access parameter are also placed in the list of private_dependents.
--- Prival (Node17)
--- Present in components. Used for representing private declarations
--- of protected objects (private formal: by analogy to Discriminal_Link).
--- Empty unless the synthesized Is_Protected_Private attribute is
--- true. The entity used as a formal parameter that corresponds to
--- the to the private declaration in protected operations. See
--- "Private data in protected objects" for details.
-
--- Privals_Chain (Elist23)
--- Present in protected operations (subprograms and entries). Links
--- all occurrences of the Privals in the body of the operation, in
--- order to patch their types at the end of their expansion. See
--- "Private data in protected objects" for details.
-
-- Private_View (Node22)
-- For each private type, three entities are allocated, the private view,
-- the full view, and the shadow entity. The shadow entity contains a
-- Present in protected operations. References the entity for the
-- subprogram which implements the body of the operation.
--- Protected_Operation (Node23)
--- Present in components. Used for representing private declarations
--- of protected objects. Empty unless the synthesized attribute
--- Is_Protected_Private is True. This is the entity corresponding
--- to the body of the protected operation currently being analyzed,
--- and which will eventually use the current Prival associated with
--- this component to refer to the renaming of a private object
--- component. As soon as the expander generates this renaming, this
--- attribute is changed to refer to the next protected subprogram.
--- See "Private data in protected objects" for details.
+-- Protection_Object (Node23)
+-- Applies to protected entries, entry families and subprograms. Denotes
+-- the entity which is used to rename the _object component of protected
+-- types.
-- Reachable (Flag49)
-- Present in labels. The flag is set over the range of statements in
-- Set to point to the entity of the associated tagged type or interface
-- type.
+-- Relative_Deadline_Variable (Node26) [implementation base type only]
+-- Present in task type entities. This flag is set if a valid and
+-- effective pragma Relative_Deadline applies to the base type. Points
+-- to the entity for a variable that is created to hold the value given
+-- in a Relative_Deadline pragma for a task type.
+
-- Renamed_Entity (Node18)
-- Present in exceptions, packages, subprograms and generic units. Set
-- for entities that are defined by a renaming declaration. Denotes the
-- size of objects of the type is known at compile time. This flag is
-- used to optimize some generated code sequences, and also to enable
-- some error checks (e.g. disallowing component clauses on variable
--- length objects. It is set conservatively (i.e. if it is True, the
+-- length objects). It is set conservatively (i.e. if it is True, the
-- size is certainly known at compile time, if it is False, then the
-- size may or may not be known at compile time, but the code will
-- assume that it is not known).
-- case where there is a separate spec, where this field references
-- the corresponding parameter entities in the spec.
+-- Spec_PPC_List (Node24)
+-- Present in subprogram entities. Points to a list of Precondition
+-- and Postcondition N_Pragma nodes for preconditions and postconditions
+-- declared in the spec. The last pragma encountered is at the head of
+-- this list, so it is in reverse order of textual appearence.
+
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
-- checks associated with declared volatile variables, but if the test
-- is for the purposes of suppressing optimizations, then the front
-- end should test Treat_As_Volatile rather than Is_Volatile.
+--
+-- Note: before testing Treat_As_Volatile, consider whether it would
+-- be more appropriate to use Exp_Util.Is_Volatile_Reference instead,
+-- which catches more cases of volatile references.
-- Type_High_Bound (synthesized)
-- Applies to scalar types. Returns the tree node (Node_Id) that contains
-- Etype (Node5)
-- First_Rep_Item (Node6)
-- Freeze_Node (Node7)
- -- Obsolescent_Warning (Node24)
-- Address_Taken (Flag104)
-- Can_Never_Be_Null (Flag38)
-- Is_Compilation_Unit (Flag149)
-- Is_Completely_Hidden (Flag103)
-- Is_Discrim_SO_Function (Flag176)
+ -- Is_Dispatch_Table_Entity (Flag234)
-- Is_Dispatching_Operation (Flag6)
-- Is_Entry_Formal (Flag52)
-- Is_Exported (Flag99)
-- Is_Remote_Types (Flag61)
-- Is_Renaming_Of_Object (Flag112)
-- Is_Shared_Passive (Flag60)
- -- Is_Static_Dispatch_Table_Entity (Flag234)
-- Is_Statically_Allocated (Flag28)
-- Is_Tagged_Type (Flag55)
-- Is_Trivial_Subprogram (Flag235)
-- Needs_Debug_Info (Flag147)
-- Never_Set_In_Source (Flag115)
-- No_Return (Flag113)
+ -- Overlays_Constant (Flag243)
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
-- Referenced_As_Out_Parameter (Flag227)
-- Is_Derived_Type (synth)
-- Is_Dynamic_Scope (synth)
-- Is_Limited_Type (synth)
+ -- Is_Standard_Character_Type (synth)
-- Underlying_Type (synth)
-- all classification attributes (synth)
-- Known_To_Have_Preelab_Init (Flag207)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208)
+ -- Optimize_Alignment_Space (Flag241)
+ -- Optimize_Alignment_Time (Flag242)
-- Size_Depends_On_Discriminant (Flag177)
-- Size_Known_At_Compile_Time (Flag92)
-- Strict_Alignment (Flag145) (base type only)
-- Directly_Designated_Type (Node20)
-- Needs_No_Actuals (Flag22)
-- Can_Use_Internal_Rep (Flag229)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
-- Needs_No_Actuals (Flag22)
-- Can_Use_Internal_Rep (Flag229)
- -- (plus type attributes)
+ -- (plus type attributes)
-- E_Access_Type
-- E_Access_Subtype
-- Discriminant_Checking_Func (Node20)
-- Interface_Name (Node21) (JGNAT usage only)
-- Original_Record_Component (Node22)
- -- Protected_Operation (Node23)
-- DT_Offset_To_Top_Func (Node25)
-- Related_Type (Node26)
-- Has_Biased_Representation (Flag139)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
-- Is_Return_Object (Flag209)
- -- Is_Protected_Private (synth)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
-- Next_Tag_Component (synth)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
+ -- Prival_Link (Node20) (privals only)
-- Interface_Name (Node21)
-- Related_Type (Node26) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
+ -- Optimize_Alignment_Space (Flag241) (constants only)
+ -- Optimize_Alignment_Time (Flag242) (constants only)
-- Treat_As_Volatile (Flag41)
- -- Is_Return_Object (Flag209)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Constant_Value (synth)
-- Last_Entity (Node20)
-- Accept_Address (Elist21)
-- Scope_Depth_Value (Uint22)
- -- Privals_Chain (Elist23) (for a protected entry)
+ -- Protection_Object (Node23) (protected kind)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
-- Is_AST_Entry (Flag132) (for entry only)
-- Scope_Depth_Value (Uint22)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic function only)
- -- Privals_Chain (Elist23) (protected func only)
+ -- Protection_Object (Node23) (for concurrent kind)
-- Abstract_Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Extra_Formals (Node28)
-- Has_Master_Entity (Flag21)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Has_Postconditions (Flag240)
-- Has_Recursive_Call (Flag143)
-- Has_Subprogram_Descriptor (Flag93)
-- Implemented_By_Entry (Flag232) (non-generic case only)
-- Extra_Formal (Node15)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-
-- Renamed_Object (Node18)
-- Spec_Entity (Node19)
-- Default_Value (Node20)
-- First_Entity (Node17)
-- Alias (Node18)
-- Last_Entity (Node20)
+ -- Has_Postconditions (Flag240)
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Primitive (Flag218)
-- Is_Thunk (Flag225)
-- Default_Expressions_Processed (Flag108)
+ -- Aren't there more flags and fields? seems like this list should be
+ -- more similar to the E_Function list, which is much longer ???
-- E_Ordinary_Fixed_Point_Type
-- E_Ordinary_Fixed_Point_Subtype
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Limited_View (Node23) (non-generic/instance)
- -- Current_Use_Clause (Node25)
+ -- Current_Use_Clause (Node27)
-- Package_Instantiation (Node26)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Scope_Depth_Value (Uint22)
-- Generic_Renamings (Elist23) (for instance)
-- Inner_Instances (Elist23) (for generic proc)
- -- Privals_Chain (Elist23) (for protected proc)
+ -- Protection_Object (Node23) (for concurrent kind)
+ -- Spec_PPC_List (Node24) (non-generic case only)
-- Abstract_Interface_Alias (Node25)
-- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26)
-- Has_Completion (Flag26)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Has_Postconditions (Flag240)
-- Has_Subprogram_Descriptor (Flag93)
-- Implemented_By_Entry (Flag232) (non-generic case only)
-- Is_Visible_Child_Unit (Flag116)
-- First_Formal (synth)
-- First_Formal_With_Extras (synth)
-- Number_Formals (synth)
- -- Delay_Cleanups (Flag114)
- -- Discard_Names (Flag88)
-- E_Protected_Body
- -- Object_Ref (Node17)
-- (any others??? First/Last Entity, Scope_Depth???)
-- E_Protected_Object
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Has_Entries (synth)
-- Number_Entries (synth)
+ -- Relative_Deadline_Variable (Node26) (base type only)
-- (plus type attributes)
-- E_Variable
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19)
+ -- Prival_Link (Node20)
-- Interface_Name (Node21)
-- Shared_Var_Assign_Proc (Node22)
-- Extra_Constrained (Node23)
-- Has_Biased_Representation (Flag139)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
+ -- Has_Up_Level_Access (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
- -- Treat_As_Volatile (Flag41)
-- Is_Return_Object (Flag209)
- -- Has_Up_Level_Access (Flag215)
+ -- Optimize_Alignment_Space (Flag241)
+ -- Optimize_Alignment_Time (Flag242)
+ -- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Constant_Value (synth)
-- general manner, like any other variables:
-- In initialization expressions for records. Note that the expressions
- -- used in Priority, Storage_Size, and Task_Info pragmas are effectively
- -- in this category, since these pragmas are converted to initialized
- -- record fields in the Corresponding_Record_Type.
+ -- used in Priority, Storage_Size, Task_Info and Relative_Deadline
+ -- pragmas are effectively in this category, since these pragmas are
+ -- converted to initialized record fields in the Corresponding_Record_
+ -- Type.
-- In task and protected bodies, where the discriminant values may be
-- referenced freely within these bodies. Discriminants can also appear
-- objects. The following approach is used to simplify and minimize the
-- special processing that is required.
- -- When a record type with discriminants is processed, the semantic
- -- processing creates the entities for the discriminants. It also creates
- -- an additional set of entities, called discriminals, one for each of
- -- the discriminants, and the Discriminal field of the discriminant entity
- -- points to this additional entity, which is initially created as an
- -- uninitialized (E_Void) entity.
+ -- When a record type with discriminants is analyzed, semantic processing
+ -- creates the entities for the discriminants. It also creates additional
+ -- sets of entities called discriminals, one for each of the discriminants,
+ -- and the Discriminal field of the discriminant entity points to this
+ -- additional entity, which is initially created as an uninitialized
+ -- (E_Void) entity.
-- During expansion of expressions, any discriminant reference is replaced
-- by a reference to the corresponding discriminal. When the initialization
-- have already been replaced by references to these discriminals, which
-- are now the formal parameters corresponding to the required objects.
- -- In the case of a task or protected body, the semantics similarly
- -- creates a set of discriminals for the discriminants of the task or
- -- protected type. When the procedure is created for the task body,
- -- the parameter passed in is a reference to the task value type, which
- -- contains the required discriminant values. The expander creates a
- -- set of declarations of the form:
+ -- In the case of a task or protected body, the semantics similarly creates
+ -- a set of discriminals for the discriminants of the task or protected
+ -- type. When the procedure is created for the task body, the parameter
+ -- passed in is a reference to the task value type, which contains the
+ -- required discriminant values. The expander creates a set of declarations
+ -- of the form:
- -- discriminal : constant dtype renames _Task.discriminant;
+ -- discr_nameD : constant disrc_type renames _task.discr_name;
- -- where discriminal is the discriminal entity referenced by the task
- -- discriminant, and _Task is the task value passed in as the parameter.
+ -- where discr_nameD is the discriminal entity referenced by the task
+ -- discriminant, and _task is the task value passed in as the parameter.
-- Again, any references to discriminants in the task body have been
-- replaced by the discriminal reference, which is now an object that
-- contains the required value.
-- The one bit of trickiness arises in making sure that the right set of
-- discriminals is used at the right time. First the task definition is
-- processed. Any references to discriminants here are replaced by the
- -- the corresponding *task* discriminals (the record type doesn't even
- -- exist yet, since it is constructed as part of the expansion of the
- -- task declaration, which happens after the semantic processing of the
- -- task definition). The discriminants to be used for the corresponding
- -- record are created at the same time as the other discriminals, and
- -- held in the CR_Discriminant field of the discriminant. A use of the
- -- discriminant in a bound for an entry family is replaced with the CR_
- -- discriminant because it controls the bound of the entry queue array
- -- which is a component of the corresponding record.
+ -- corresponding *task* discriminals (the record type doesn't even exist
+ -- yet, since it is constructed as part of the expansion of the task
+ -- declaration, which happens after the semantic processing of the task
+ -- definition). The discriminants to be used for the corresponding record
+ -- are created at the same time as the other discriminals, and held in the
+ -- CR_Discriminant field of the discriminant. A use of the discriminant in
+ -- a bound for an entry family is replaced with the CR_Discriminant because
+ -- it controls the bound of the entry queue array which is a component of
+ -- the corresponding record.
-- Just before the record initialization routine is constructed, the
-- expander exchanges the task and record discriminals. This has two
-- task body, and also for the discriminal declarations at the start of
-- the task body.
- ---------------------------------------
- -- Private data in protected objects --
- ---------------------------------------
-
- -- Private object declarations in protected types pose problems
- -- similar to those of discriminants. They are expanded to components
- -- of a record which is passed as the parameter "_object" to expanded
- -- forms of all protected operations. As with discriminants, timing
- -- of this expansion is a problem. The sequence of statements for a
- -- protected operation is expanded before the operation itself, so the
- -- formal parameter for the record object containing the private data
- -- does not exist when the references to that data are expanded.
-
- -- For this reason, private data is handled in the same way as
- -- discriminants, expanding references to private data in protected
- -- operations (which appear as components) to placeholders which will
- -- eventually become renamings of the private selected components
- -- of the "_object" formal parameter. These placeholders are called
- -- "privals", by analogy to the "discriminals" used to implement
- -- discriminants. They are attached to the component declaration nodes
- -- representing the private object declarations of the protected type.
-
- -- As with discriminals, each protected subprogram needs a unique set
- -- of privals, since they must refer to renamings of components of a
- -- formal parameter of that operation. Entry bodies need another set,
- -- which they all share and which is associated with renamings in the
- -- Service_Entries procedure for the protected type (this is not yet
- -- implemented???). This means that we must associate a new set of
- -- privals (and discriminals) with the private declarations after
- -- the body of a protected subprogram is processed.
-
- -- The last complication is the presence of discriminants and discriminated
- -- components. In the corresponding record, the components are constrained
- -- by the discriminants of the record, but within each protected operation
- -- they are constrained by the discriminants of the actual. The actual
- -- subtypes of those components are constructed as for other unconstrained
- -- formals, but the privals are created before the formal object is added
- -- to the parameter list of the protected operation, so they carry the
- -- nominal subtype of the original component. After the protected operation
- -- is actually created (in the expansion of the protected body) we must
- -- patch the types of each prival occurrence with the proper actual subtype
- -- which is by now set. The Privals_Chain is used for this patching.
+ ---------------------------------------------------
+ -- Handling of private data in protected objects --
+ ---------------------------------------------------
+
+ -- Private components in protected types pose problems similar to those
+ -- of discriminants. Private data is visible and can be directly referenced
+ -- from protected bodies. However, when protected entries and subprograms
+ -- are expanded into corresponding bodies and barrier functions, private
+ -- components lose their original context and visibility.
+
+ -- To remedy this side effect of expansion, private components are expanded
+ -- into renamings called "privals", by analogy with "discriminals".
+
+ -- private_comp : comp_type renames _object.private_comp;
+
+ -- Prival declarations are inserted during the analysis of subprogram and
+ -- entry bodies to ensure proper visibility for any subsequent expansion.
+ -- _Object is the formal parameter of the generated corresponding body or
+ -- a local renaming which denotes the protected object obtained from entry
+ -- parameter _O. Privals receive minimal decoration upon creation and are
+ -- categorized as either E_Variable for the general case or E_Constant when
+ -- they appear in functions.
+
+ -- Along with the local declarations, each private component carries a
+ -- placeholder which references the prival entity in the current body. This
+ -- form of indirection is used to resolve name clashes of privals and other
+ -- locally visible entities such as parameters, local objects, entry family
+ -- indexes or identifiers used in the barrier condition.
+
+ -- When analyzing the statements of a protected subprogram or entry, any
+ -- reference to a private component must resolve to the locally declared
+ -- prival through normal visibility. In case of name conflicts (the cases
+ -- above), the prival is marked as hidden and acts as a weakly declared
+ -- entity. As a result, the reference points to the correct entity. When a
+ -- private component is denoted by an expanded name (prot_type.comp for
+ -- example), the expansion mechanism uses the placeholder of the component
+ -- to correct the Entity and Etype of the reference.
-------------------
-- Type Synonyms --
-------------------
-- The following type synonyms are used to tidy up the function and
- -- procedure declarations that follow, and also to make it possible
- -- to meet the requirement for the XEINFO utility that all function
- -- specs must fit on a single source line.
+ -- procedure declarations that follow, and also to make it possible to meet
+ -- the requirement for the XEINFO utility that all function specs must fit
+ -- on a single source line.
subtype B is Boolean;
subtype C is Component_Alignment_Kind;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
function Has_Persistent_BSS (Id : E) return B;
+ function Has_Postconditions (Id : E) return B;
function Has_Pragma_Controlled (Id : E) return B;
function Has_Pragma_Elaborate_Body (Id : E) return B;
function Has_Pragma_Inline (Id : E) return B;
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
+ function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
function Is_Renaming_Of_Object (Id : E) return B;
function Is_Return_Object (Id : E) return B;
function Is_Shared_Passive (Id : E) return B;
- function Is_Static_Dispatch_Table_Entity (Id : E) return B;
function Is_Statically_Allocated (Id : E) return B;
function Is_Synchronized_Interface (Id : E) return B;
function Is_Tag (Id : E) return B;
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
- function Object_Ref (Id : E) return E;
- function Obsolescent_Warning (Id : E) return N;
function OK_To_Reorder_Components (Id : E) return B;
+ function Optimize_Alignment_Space (Id : E) return B;
+ function Optimize_Alignment_Time (Id : E) return B;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
+ function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E;
function Package_Instantiation (Id : E) return N;
function Packed_Array_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Primitive_Operations (Id : E) return L;
function Prival (Id : E) return E;
- function Privals_Chain (Id : E) return L;
+ function Prival_Link (Id : E) return E;
function Private_Dependents (Id : E) return L;
function Private_View (Id : E) return N;
function Protected_Body_Subprogram (Id : E) return E;
function Protected_Formal (Id : E) return E;
- function Protected_Operation (Id : E) return E;
+ function Protection_Object (Id : E) return E;
function RM_Size (Id : E) return U;
function Reachable (Id : E) return B;
function Referenced (Id : E) return B;
function Related_Array_Object (Id : E) return E;
function Related_Instance (Id : E) return E;
function Related_Type (Id : E) return E;
+ function Relative_Deadline_Variable (Id : E) return E;
function Renamed_Entity (Id : E) return N;
function Renamed_In_Spec (Id : E) return B;
function Renamed_Object (Id : E) return N;
function Size_Depends_On_Discriminant (Id : E) return B;
function Small_Value (Id : E) return R;
function Spec_Entity (Id : E) return E;
+ function Spec_PPC_List (Id : E) return N;
function Storage_Size_Variable (Id : E) return E;
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
function Is_Boolean_Type (Id : E) return B;
function Is_By_Copy_Type (Id : E) return B;
function Is_By_Reference_Type (Id : E) return B;
+ function Is_Constant_Object (Id : E) return B;
function Is_Derived_Type (Id : E) return B;
+ function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
function Is_Indefinite_Subtype (Id : E) return B;
function Is_Limited_Type (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
- function Is_Protected_Private (Id : E) return B;
+ function Is_Prival (Id : E) return B;
+ function Is_Protected_Component (Id : E) return B;
function Is_Protected_Record_Type (Id : E) return B;
function Is_Inherently_Limited_Type (Id : E) return B;
+ function Is_Standard_Character_Type (Id : E) return B;
function Is_String_Type (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
procedure Set_Has_Persistent_BSS (Id : E; V : B := True);
+ procedure Set_Has_Postconditions (Id : E; V : B := True);
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
+ procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True);
procedure Set_Is_Return_Object (Id : E; V : B := True);
procedure Set_Is_Shared_Passive (Id : E; V : B := True);
- procedure Set_Is_Static_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
procedure Set_Is_Synchronized_Interface (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
- procedure Set_Object_Ref (Id : E; V : E);
- procedure Set_Obsolescent_Warning (Id : E; V : N);
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True);
+ procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
+ procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
+ procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_Package_Instantiation (Id : E; V : N);
procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Primitive_Operations (Id : E; V : L);
procedure Set_Prival (Id : E; V : E);
- procedure Set_Privals_Chain (Id : E; V : L);
+ procedure Set_Prival_Link (Id : E; V : E);
procedure Set_Private_Dependents (Id : E; V : L);
procedure Set_Private_View (Id : E; V : N);
procedure Set_Protected_Body_Subprogram (Id : E; V : E);
procedure Set_Protected_Formal (Id : E; V : E);
- procedure Set_Protected_Operation (Id : E; V : N);
+ procedure Set_Protection_Object (Id : E; V : E);
procedure Set_RM_Size (Id : E; V : U);
procedure Set_Reachable (Id : E; V : B := True);
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Instance (Id : E; V : E);
procedure Set_Related_Type (Id : E; V : E);
+ procedure Set_Relative_Deadline_Variable (Id : E; V : E);
procedure Set_Renamed_Entity (Id : E; V : N);
procedure Set_Renamed_In_Spec (Id : E; V : B := True);
procedure Set_Renamed_Object (Id : E; V : N);
procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True);
procedure Set_Small_Value (Id : E; V : R);
procedure Set_Spec_Entity (Id : E; V : E);
+ procedure Set_Spec_PPC_List (Id : E; V : N);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Per_Object_Constraint);
pragma Inline (Has_Persistent_BSS);
+ pragma Inline (Has_Postconditions);
pragma Inline (Has_Pragma_Controlled);
pragma Inline (Has_Pragma_Elaborate_Body);
pragma Inline (Has_Pragma_Inline);
pragma Inline (Is_Descendent_Of_Address);
pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
pragma Inline (Is_Discrete_Type);
+ pragma Inline (Is_Dispatch_Table_Entity);
pragma Inline (Is_Dispatching_Operation);
pragma Inline (Is_Elementary_Type);
pragma Inline (Is_Eliminated);
pragma Inline (Is_Scalar_Type);
pragma Inline (Is_Shared_Passive);
pragma Inline (Is_Signed_Integer_Type);
- pragma Inline (Is_Static_Dispatch_Table_Entity);
pragma Inline (Is_Statically_Allocated);
pragma Inline (Is_Subprogram);
pragma Inline (Is_Synchronized_Interface);
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
- pragma Inline (Object_Ref);
- pragma Inline (Obsolescent_Warning);
pragma Inline (OK_To_Reorder_Components);
+ pragma Inline (Optimize_Alignment_Space);
+ pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
+ pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation);
pragma Inline (Package_Instantiation);
pragma Inline (Packed_Array_Type);
pragma Inline (Parent_Subtype);
pragma Inline (Primitive_Operations);
pragma Inline (Prival);
- pragma Inline (Privals_Chain);
+ pragma Inline (Prival_Link);
pragma Inline (Private_Dependents);
pragma Inline (Private_View);
pragma Inline (Protected_Body_Subprogram);
pragma Inline (Protected_Formal);
- pragma Inline (Protected_Operation);
+ pragma Inline (Protection_Object);
pragma Inline (RM_Size);
pragma Inline (Reachable);
pragma Inline (Referenced);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Instance);
pragma Inline (Related_Type);
+ pragma Inline (Relative_Deadline_Variable);
pragma Inline (Renamed_Entity);
pragma Inline (Renamed_In_Spec);
pragma Inline (Renamed_Object);
pragma Inline (Size_Known_At_Compile_Time);
pragma Inline (Small_Value);
pragma Inline (Spec_Entity);
+ pragma Inline (Spec_PPC_List);
pragma Inline (Storage_Size_Variable);
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func);
pragma Inline (Set_DT_Position);
+ pragma Inline (Set_Relative_Deadline_Variable);
pragma Inline (Set_Default_Expr_Function);
pragma Inline (Set_Default_Expressions_Processed);
pragma Inline (Set_Default_Value);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Per_Object_Constraint);
pragma Inline (Set_Has_Persistent_BSS);
+ pragma Inline (Set_Has_Postconditions);
pragma Inline (Set_Has_Pragma_Controlled);
pragma Inline (Set_Has_Pragma_Elaborate_Body);
pragma Inline (Set_Has_Pragma_Inline);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_Descendent_Of_Address);
pragma Inline (Set_Is_Discrim_SO_Function);
+ pragma Inline (Set_Is_Dispatch_Table_Entity);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Renaming_Of_Object);
pragma Inline (Set_Is_Return_Object);
pragma Inline (Set_Is_Shared_Passive);
- pragma Inline (Set_Is_Static_Dispatch_Table_Entity);
pragma Inline (Set_Is_Statically_Allocated);
pragma Inline (Set_Is_Synchronized_Interface);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Normalized_First_Bit);
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
- pragma Inline (Set_Object_Ref);
- pragma Inline (Set_Obsolescent_Warning);
pragma Inline (Set_OK_To_Reorder_Components);
+ pragma Inline (Set_Optimize_Alignment_Space);
+ pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
+ pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Package_Instantiation);
pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Primitive_Operations);
pragma Inline (Set_Prival);
- pragma Inline (Set_Privals_Chain);
+ pragma Inline (Set_Prival_Link);
pragma Inline (Set_Private_Dependents);
pragma Inline (Set_Private_View);
pragma Inline (Set_Protected_Body_Subprogram);
pragma Inline (Set_Protected_Formal);
- pragma Inline (Set_Protected_Operation);
+ pragma Inline (Set_Protection_Object);
pragma Inline (Set_RM_Size);
pragma Inline (Set_Reachable);
pragma Inline (Set_Referenced);
pragma Inline (Set_Size_Known_At_Compile_Time);
pragma Inline (Set_Small_Value);
pragma Inline (Set_Spec_Entity);
+ pragma Inline (Set_Spec_PPC_List);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Ch2; use Exp_Ch2;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Imgv; use Exp_Imgv;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
+with Fname; use Fname;
with Freeze; use Freeze;
with Gnatvsn; use Gnatvsn;
with Itypes; use Itypes;
function May_Be_External_Call return Boolean is
Subp : Entity_Id;
+ Par : Node_Id := Parent (N);
+
begin
- if (Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else Nkind (Parent (N)) = N_Function_Call)
- and then Is_Entity_Name (Name (Parent (N)))
+ -- Account for the case where the Access attribute is part of a
+ -- named parameter association.
+
+ if Nkind (Par) = N_Parameter_Association then
+ Par := Parent (Par);
+ end if;
+
+ if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)
+ and then Is_Entity_Name (Name (Par))
then
- Subp := Entity (Name (Parent (N)));
+ Subp := Entity (Name (Par));
return not In_Open_Scopes (Scope (Subp));
else
return False;
-- current enclosing operation.
if Is_Entity_Name (Pref) then
- pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
-
if May_Be_External_Call then
Sub :=
New_Occurrence_Of
(Protected_Body_Subprogram (Entity (Pref)), Loc);
end if;
+ -- Don't traverse the scopes when the attribute occurs within an init
+ -- proc, because we directly use the _init formal of the init proc in
+ -- that case.
+
Curr := Current_Scope;
- while Scope (Curr) /= Scope (Entity (Pref)) loop
- Curr := Scope (Curr);
- end loop;
+ if not Is_Init_Proc (Curr) then
+ pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
+
+ while Scope (Curr) /= Scope (Entity (Pref)) loop
+ Curr := Scope (Curr);
+ end loop;
+ end if;
-- In case of protected entries the first formal of its Protected_
-- Body_Subprogram is the address of the object.
(First_Formal
(Protected_Body_Subprogram (Curr)), Loc);
+ -- If the current scope is an init proc, then use the address of the
+ -- _init formal as the object reference.
+
+ elsif Is_Init_Proc (Curr) then
+ Obj_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
+ Attribute_Name => Name_Address);
+
-- In case of protected subprograms the first formal of its
-- Protected_Body_Subprogram is the object and we get its address.
Typ : constant Entity_Id := Etype (N);
Btyp : constant Entity_Id := Base_Type (Typ);
Pref : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (Pref);
Exprs : constant List_Id := Expressions (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
end;
end if;
+ -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
+ -- place function, then a temporary return object needs to be created
+ -- and access to it must be passed to the function. Currently we limit
+ -- such functions to those with inherently limited result subtypes, but
+ -- eventually we plan to expand the functions that are treated as
+ -- build-in-place to include other composite result types.
+
+ if Ada_Version >= Ada_05
+ and then Is_Build_In_Place_Function_Call (Pref)
+ then
+ Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+ end if;
+
-- Remaining processing depends on specific attribute
case Id is
if Id = Attribute_Unrestricted_Access
and then Is_Subprogram (Directly_Designated_Type (Typ))
then
- -- The following assertion ensures that this special management
+ -- The following conditions ensure that this special management
-- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
-- At this stage other cases in which the designated type is
-- still a subprogram (instead of an E_Subprogram_Type) are
-- wrong because the semantics must have overridden the type of
-- the node with the type imposed by the context.
- pragma Assert (Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then Etype (Parent (N)) = RTE (RE_Address));
-
- declare
- Subp : constant Entity_Id := Directly_Designated_Type (Typ);
-
- Extra : Entity_Id := Empty;
- New_Formal : Entity_Id;
- Old_Formal : Entity_Id := First_Formal (Subp);
- Subp_Typ : Entity_Id;
+ if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ then
+ Set_Etype (N, RTE (RE_Prim_Ptr));
- begin
- Subp_Typ := Create_Itype (E_Subprogram_Type, N);
- Set_Etype (Subp_Typ, Etype (Subp));
- Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
+ else
+ declare
+ Subp : constant Entity_Id :=
+ Directly_Designated_Type (Typ);
+ Etyp : Entity_Id;
+ Extra : Entity_Id := Empty;
+ New_Formal : Entity_Id;
+ Old_Formal : Entity_Id := First_Formal (Subp);
+ Subp_Typ : Entity_Id;
- if Present (Old_Formal) then
- New_Formal := New_Copy (Old_Formal);
- Set_First_Entity (Subp_Typ, New_Formal);
+ begin
+ Subp_Typ := Create_Itype (E_Subprogram_Type, N);
+ Set_Etype (Subp_Typ, Etype (Subp));
+ Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
- loop
- Set_Scope (New_Formal, Subp_Typ);
+ if Present (Old_Formal) then
+ New_Formal := New_Copy (Old_Formal);
+ Set_First_Entity (Subp_Typ, New_Formal);
- -- Handle itypes
+ loop
+ Set_Scope (New_Formal, Subp_Typ);
+ Etyp := Etype (New_Formal);
- if Is_Itype (Etype (New_Formal)) then
- Extra := New_Copy (Etype (New_Formal));
+ -- Handle itypes. There is no need to duplicate
+ -- here the itypes associated with record types
+ -- (i.e the implicit full view of private types).
- if Ekind (Extra) = E_Record_Subtype
- or else Ekind (Extra) = E_Class_Wide_Subtype
+ if Is_Itype (Etyp)
+ and then Ekind (Base_Type (Etyp)) /= E_Record_Type
then
- Set_Cloned_Subtype (Extra,
- Etype (New_Formal));
+ Extra := New_Copy (Etyp);
+ Set_Parent (Extra, New_Formal);
+ Set_Etype (New_Formal, Extra);
+ Set_Scope (Extra, Subp_Typ);
end if;
- Set_Etype (New_Formal, Extra);
- Set_Scope (Etype (New_Formal), Subp_Typ);
- end if;
-
- Extra := New_Formal;
- Next_Formal (Old_Formal);
- exit when No (Old_Formal);
-
- Set_Next_Entity (New_Formal,
- New_Copy (Old_Formal));
- Next_Entity (New_Formal);
- end loop;
+ Extra := New_Formal;
+ Next_Formal (Old_Formal);
+ exit when No (Old_Formal);
- Set_Next_Entity (New_Formal, Empty);
- Set_Last_Entity (Subp_Typ, Extra);
- end if;
-
- -- Now that the explicit formals have been duplicated,
- -- any extra formals needed by the subprogram must be
- -- created.
-
- if Present (Extra) then
- Set_Extra_Formal (Extra, Empty);
- end if;
+ Set_Next_Entity (New_Formal,
+ New_Copy (Old_Formal));
+ Next_Entity (New_Formal);
+ end loop;
- Create_Extra_Formals (Subp_Typ);
- Set_Directly_Designated_Type (Typ, Subp_Typ);
+ Set_Next_Entity (New_Formal, Empty);
+ Set_Last_Entity (Subp_Typ, Extra);
+ end if;
- -- Complete decoration of access-to-subprogram itype to
- -- indicate to the backend that this itype corresponds to
- -- a statically allocated dispatch table.
+ -- Now that the explicit formals have been duplicated,
+ -- any extra formals needed by the subprogram must be
+ -- created.
- -- ??? more comments on structure here, three level parent
- -- references are worrisome!
+ if Present (Extra) then
+ Set_Extra_Formal (Extra, Empty);
+ end if;
- if Nkind (Ref_Object) in N_Has_Entity
- and then Is_Dispatching_Operation (Entity (Ref_Object))
- and then Present (Parent (Parent (N)))
- and then Nkind (Parent (Parent (N))) = N_Aggregate
- and then Present (Parent (Parent (Parent (N))))
- then
- declare
- P : constant Node_Id :=
- Parent (Parent (Parent (N)));
- Prim : constant Entity_Id := Entity (Ref_Object);
-
- begin
- Set_Is_Static_Dispatch_Table_Entity (Typ,
- (Is_Predefined_Dispatching_Operation (Prim)
- and then Nkind (P) = N_Object_Declaration
- and then Is_Static_Dispatch_Table_Entity
- (Defining_Identifier (P)))
- or else
- (not Is_Predefined_Dispatching_Operation (Prim)
- and then Nkind (P) = N_Aggregate
- and then Present (Parent (P))
- and then Nkind (Parent (P))
- = N_Object_Declaration
- and then Is_Static_Dispatch_Table_Entity
- (Defining_Identifier (Parent (P)))));
- end;
- end if;
- end;
+ Create_Extra_Formals (Subp_Typ);
+ Set_Directly_Designated_Type (Typ, Subp_Typ);
+ end;
+ end if;
end if;
if Is_Access_Protected_Subprogram_Type (Btyp) then
if Is_Entity_Name (Pref)
and then Is_Task_Type (Entity (Pref))
then
- Task_Proc := Next_Entity (Root_Type (Etype (Pref)));
+ Task_Proc := Next_Entity (Root_Type (Ptyp));
while Present (Task_Proc) loop
exit when Ekind (Task_Proc) = E_Procedure
and then Etype (First_Formal (Task_Proc)) =
- Corresponding_Record_Type (Etype (Pref));
+ Corresponding_Record_Type (Ptyp);
Next_Entity (Task_Proc);
end loop;
External_Subprogram (Entity (Selector_Name (Pref))), Loc));
elsif Nkind (Pref) = N_Explicit_Dereference
- and then Ekind (Etype (Pref)) = E_Subprogram_Type
- and then Convention (Etype (Pref)) = Convention_Protected
+ and then Ekind (Ptyp) = E_Subprogram_Type
+ and then Convention (Ptyp) = Convention_Protected
then
-- The prefix is be a dereference of an access_to_protected_
-- subprogram. The desired address is the second component of
-- This processing is not needed in the VM case, where dispatching
-- issues are taken care of by the virtual machine.
- elsif Is_Class_Wide_Type (Etype (Pref))
- and then Is_Interface (Etype (Pref))
+ elsif Is_Class_Wide_Type (Ptyp)
+ and then Is_Interface (Ptyp)
and then VM_Target = No_VM
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
return;
end if;
- -- Deal with packed array reference, other cases are handled by gigi
+ -- Deal with packed array reference, other cases are handled by
+ -- the back end.
if Involves_Packed_Array_Reference (Pref) then
Expand_Packed_Address_Reference (N);
---------------
when Attribute_Alignment => Alignment : declare
- Ptyp : constant Entity_Id := Etype (Pref);
New_Node : Node_Id;
begin
-- Bit_Position --
------------------
- -- We compute this if a component clause was present, otherwise
- -- we leave the computation up to Gigi, since we don't know what
- -- layout will be chosen.
+ -- We compute this if a component clause was present, otherwise we leave
+ -- the computation up to the back end, since we don't know what layout
+ -- will be chosen.
-- Note that the attribute can apply to a naked record component
-- in generated code (i.e. the prefix is an identifier that
-- callable (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
- and then Ekind (Etype (Pref)) = E_Class_Wide_Type
- and then Is_Interface (Etype (Pref))
- and then Is_Task_Interface (Etype (Pref))
+ and then Ekind (Ptyp) = E_Class_Wide_Type
+ and then Is_Interface (Ptyp)
+ and then Is_Task_Interface (Ptyp)
then
Rewrite (N,
Make_Function_Call (Loc,
Unchecked_Convert_To (Id_Kind,
Make_Function_Call (Loc,
Name => Name,
- Parameter_Associations => New_List
- (New_Reference_To (
- Object_Ref
- (Corresponding_Body (Parent (Conctype))), Loc)))));
+ Parameter_Associations => New_List (
+ New_Reference_To
+ (Find_Protection_Object (Current_Scope), Loc)))));
-- Task case
Rewrite (N,
Unchecked_Convert_To (Id_Kind,
Make_Function_Call (Loc,
- Name => New_Reference_To (
- RTE (RE_Task_Entry_Caller), Loc),
+ Name =>
+ New_Reference_To (RTE (RE_Task_Entry_Caller), Loc),
Parameter_Associations => New_List (
Make_Integer_Literal (Loc,
Intval => Int (Nest_Depth))))));
when Attribute_Constrained => Constrained : declare
Formal_Ent : constant Entity_Id := Param_Entity (Pref);
- Typ : constant Entity_Id := Etype (Pref);
function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
-- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
if Present (Renamed_Object (E)) then
return Is_Constrained_Aliased_View (Renamed_Object (E));
-
else
return Is_Aliased (E) and then Is_Constrained (Etype (E));
end if;
end if;
-- If the prefix is not a variable or is aliased, then
- -- definitely true; if it's a formal parameter without
- -- an associated extra formal, then treat it as constrained.
+ -- definitely true; if it's a formal parameter without an
+ -- associated extra formal, then treat it as constrained.
-- Ada 2005 (AI-363): An aliased prefix must be known to be
-- constrained in order to set the attribute to True.
then
Res := True;
- -- Variable case, just look at type to see if it is
- -- constrained. Note that the one case where this is
- -- not accurate (the procedure formal case), has been
- -- handled above.
+ -- Variable case, look at type to see if it is constrained.
+ -- Note that the one case where this is not accurate (the
+ -- procedure formal case), has been handled above.
-- We use the Underlying_Type here (and below) in case the
-- type is private without discriminants, but the full type
New_Reference_To (Boolean_Literals (Res), Loc));
end;
- -- Prefix is not an entity name. These are also cases where
- -- we can always tell at compile time by looking at the form
- -- and type of the prefix. If an explicit dereference of an
- -- object with constrained partial view, this is unconstrained
- -- (Ada 2005 AI-363).
+ -- Prefix is not an entity name. These are also cases where we can
+ -- always tell at compile time by looking at the form and type of the
+ -- prefix. If an explicit dereference of an object with constrained
+ -- partial view, this is unconstrained (Ada 2005 AI-363).
else
Rewrite (N,
or else
(Nkind (Pref) = N_Explicit_Dereference
and then
- not Has_Constrained_Partial_View (Base_Type (Typ)))
- or else Is_Constrained (Underlying_Type (Typ))),
+ not Has_Constrained_Partial_View (Base_Type (Ptyp)))
+ or else Is_Constrained (Underlying_Type (Ptyp))),
Loc));
end if;
-- Transforms 'Count attribute into a call to the Count function
- when Attribute_Count => Count :
- declare
- Entnam : Node_Id;
- Index : Node_Id;
- Name : Node_Id;
- Call : Node_Id;
- Conctyp : Entity_Id;
+ when Attribute_Count => Count : declare
+ Call : Node_Id;
+ Conctyp : Entity_Id;
+ Entnam : Node_Id;
+ Entry_Id : Entity_Id;
+ Index : Node_Id;
+ Name : Node_Id;
begin
-- If the prefix is a member of an entry family, retrieve both
Index := Empty;
end if;
+ Entry_Id := Entity (Entnam);
+
-- Find the concurrent type in which this attribute is referenced
-- (there had better be one).
-- Protected case
if Is_Protected_Type (Conctyp) then
-
case Corresponding_Runtime_Package (Conctyp) is
when System_Tasking_Protected_Objects_Entries =>
Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
Make_Function_Call (Loc,
Name => Name,
Parameter_Associations => New_List (
- New_Reference_To (
- Object_Ref (
- Corresponding_Body (Parent (Conctyp))), Loc),
- Entry_Index_Expression (Loc,
- Entity (Entnam), Index, Scope (Entity (Entnam)))));
+ New_Reference_To
+ (Find_Protection_Object (Current_Scope), Loc),
+ Entry_Index_Expression
+ (Loc, Entry_Id, Index, Scope (Entry_Id))));
when System_Tasking_Protected_Objects_Single_Entry =>
- Name := New_Reference_To
- (RTE (RE_Protected_Count_Entry), Loc);
+ Name :=
+ New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
Call :=
Make_Function_Call (Loc,
Name => Name,
Parameter_Associations => New_List (
- New_Reference_To (
- Object_Ref (
- Corresponding_Body (Parent (Conctyp))), Loc)));
+ New_Reference_To
+ (Find_Protection_Object (Current_Scope), Loc)));
+
when others =>
raise Program_Error;
-
end case;
-- Task case
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Task_Count), Loc),
Parameter_Associations => New_List (
- Entry_Index_Expression
- (Loc, Entity (Entnam), Index, Scope (Entity (Entnam)))));
+ Entry_Index_Expression (Loc,
+ Entry_Id, Index, Scope (Entry_Id))));
end if;
-- The call returns type Natural but the context is universal integer
-- Elaborated --
----------------
- -- Elaborated is always True for preelaborated units, predefined
- -- units, pure units and units which have Elaborate_Body pragmas.
- -- These units have no elaboration entity.
+ -- Elaborated is always True for preelaborated units, predefined units,
+ -- pure units and units which have Elaborate_Body pragmas. These units
+ -- have no elaboration entity.
- -- Note: The Elaborated attribute is never passed through to Gigi
+ -- Note: The Elaborated attribute is never passed to the back end
when Attribute_Elaborated => Elaborated : declare
Ent : constant Entity_Id := Entity (Pref);
-- target-type (Y)
- -- This is simply a direct conversion from the enumeration type
- -- to the target integer type, which is treated by Gigi as a normal
- -- integer conversion, treating the enumeration type as an integer,
- -- which is exactly what we want! We set Conversion_OK to make sure
- -- that the analyzer does not complain about what otherwise might
- -- be an illegal conversion.
+ -- This is simply a direct conversion from the enumeration type to
+ -- the target integer type, which is treated by the back end as a
+ -- normal integer conversion, treating the enumeration type as an
+ -- integer, which is exactly what we want! We set Conversion_OK to
+ -- make sure that the analyzer does not complain about what otherwise
+ -- might be an illegal conversion.
if Is_Non_Empty_List (Exprs) then
Rewrite (N,
Set_Etype (N, Typ);
Analyze_And_Resolve (N, Typ);
-
end Enum_Rep;
--------------
+ -- Enum_Val --
+ --------------
+
+ when Attribute_Enum_Val => Enum_Val : declare
+ Expr : Node_Id;
+ Btyp : constant Entity_Id := Base_Type (Ptyp);
+
+ begin
+ -- X'Enum_Val (Y) expands to
+
+ -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
+ -- X!(Y);
+
+ Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Duplicate_Subexpr (Expr)),
+ New_Occurrence_Of (Standard_False, Loc))),
+
+ Right_Opnd => Make_Integer_Literal (Loc, -1)),
+ Reason => CE_Range_Check_Failed));
+
+ Rewrite (N, Expr);
+ Analyze_And_Resolve (N, Ptyp);
+ end Enum_Val;
+
+ --------------
-- Exponent --
--------------
-- First --
-----------
- when Attribute_First => declare
- Ptyp : constant Entity_Id := Etype (Pref);
+ when Attribute_First =>
- begin
-- If the prefix type is a constrained packed array type which
-- already has a Packed_Array_Type representation defined, then
-- replace this attribute with a direct reference to 'First of the
- -- appropriate index subtype (since otherwise Gigi will try to give
- -- us the value of 'First for this implementation type).
+ -- appropriate index subtype (since otherwise the back end will try
+ -- to give us the value of 'First for this implementation type).
if Is_Constrained_Packed_Array (Ptyp) then
Rewrite (N,
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
end if;
- end;
---------------
-- First_Bit --
---------------
- -- We compute this if a component clause was present, otherwise
- -- we leave the computation up to Gigi, since we don't know what
+ -- Compute this if component clause was present, otherwise we leave the
+ -- computation to be completed in the back-end, since we don't know what
-- layout will be chosen.
- when Attribute_First_Bit => First_Bit :
- declare
+ when Attribute_First_Bit => First_Bit : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
-- fixtype(integer-value)
- -- we do all the required analysis of the conversion here, because
- -- we do not want this to go through the fixed-point conversion
- -- circuits. Note that gigi always treats fixed-point as equivalent
- -- to the corresponding integer type anyway.
+ -- We do all the required analysis of the conversion here, because we do
+ -- not want this to go through the fixed-point conversion circuits. Note
+ -- that the back end always treats fixed-point as equivalent to the
+ -- corresponding integer type anyway.
when Attribute_Fixed_Value => Fixed_Value :
begin
-- Note that we know that the type is a non-static subtype, or Fore
-- would have itself been computed dynamically in Eval_Attribute.
- when Attribute_Fore => Fore :
- declare
- Ptyp : constant Entity_Id := Etype (Pref);
-
- begin
+ when Attribute_Fore => Fore : begin
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Id_Kind : Entity_Id;
begin
- if Etype (Pref) = Standard_Exception_Type then
+ if Ptyp = Standard_Exception_Type then
Id_Kind := RTE (RE_Exception_Id);
if Present (Renamed_Object (Entity (Pref))) then
-- attributes applied to interfaces.
if Ada_Version >= Ada_05
- and then Ekind (Etype (Pref)) = E_Class_Wide_Type
- and then Is_Interface (Etype (Pref))
- and then Is_Task_Interface (Etype (Pref))
+ and then Ekind (Ptyp) = E_Class_Wide_Type
+ and then Is_Interface (Ptyp)
+ and then Is_Task_Interface (Ptyp)
then
Rewrite (N,
Unchecked_Convert_To (Id_Kind,
begin
Rewrite (N,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Etype (Pref), Loc),
+ Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Image,
Expressions => New_List (Relocate_Node (Pref))));
-- sourcetyp (streamread (strmtyp'Input (stream)));
- -- where stmrearead is the given Read function that converts
- -- an argument of type strmtyp to type sourcetyp or a type
- -- from which it is derived. The extra conversion is required
- -- for the derived case.
+ -- where stmrearead is the given Read function that converts an
+ -- argument of type strmtyp to type sourcetyp or a type from which
+ -- it is derived (extra conversion required for the derived case).
Prag := Get_Stream_Convert_Pragma (P_Type);
pragma Assert
(Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
- -- Ada 2005 (AI-216): Program_Error is raised when executing
- -- the default implementation of the Input attribute of an
- -- unchecked union type if the type lacks default discriminant
- -- values.
+ -- Ada 2005 (AI-216): Program_Error is raised executing default
+ -- implementation of the Input attribute of an unchecked union
+ -- type if the type lacks default discriminant values.
if Is_Unchecked_Union (Base_Type (U_Type))
and then No (Discriminant_Constraint (U_Type))
-- inttype(integer-value))
- -- we do all the required analysis of the conversion here, because
- -- we do not want this to go through the fixed-point conversion
- -- circuits. Note that gigi always treats fixed-point as equivalent
- -- to the corresponding integer type anyway.
+ -- we do all the required analysis of the conversion here, because we do
+ -- not want this to go through the fixed-point conversion circuits. Note
+ -- that the back end always treats fixed-point as equivalent to the
+ -- corresponding integer type anyway.
when Attribute_Integer_Value => Integer_Value :
begin
Apply_Type_Conversion_Checks (N);
end Integer_Value;
+ -------------------
+ -- Invalid_Value --
+ -------------------
+
+ when Attribute_Invalid_Value =>
+ Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
+
----------
-- Last --
----------
- when Attribute_Last => declare
- Ptyp : constant Entity_Id := Etype (Pref);
+ when Attribute_Last =>
- begin
-- If the prefix type is a constrained packed array type which
-- already has a Packed_Array_Type representation defined, then
-- replace this attribute with a direct reference to 'Last of the
- -- appropriate index subtype (since otherwise Gigi will try to give
- -- us the value of 'Last for this implementation type).
+ -- appropriate index subtype (since otherwise the back end will try
+ -- to give us the value of 'Last for this implementation type).
if Is_Constrained_Packed_Array (Ptyp) then
Rewrite (N,
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
end if;
- end;
--------------
-- Last_Bit --
--------------
- -- We compute this if a component clause was present, otherwise
- -- we leave the computation up to Gigi, since we don't know what
- -- layout will be chosen.
+ -- We compute this if a component clause was present, otherwise we leave
+ -- the computation up to the back end, since we don't know what layout
+ -- will be chosen.
- when Attribute_Last_Bit => Last_Bit :
- declare
+ when Attribute_Last_Bit => Last_Bit : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
-- Transforms 'Leading_Part into a call to the floating-point attribute
-- function Leading_Part in Fat_xxx (where xxx is the root type)
- -- Note: strictly, we should have special case code to deal with
+ -- Note: strictly, we should generate special case code to deal with
-- absurdly large positive arguments (greater than Integer'Last), which
-- result in returning the first argument unchanged, but it hardly seems
-- worth the effort. We raise constraint error for absurdly negative
------------
when Attribute_Length => declare
- Ptyp : constant Entity_Id := Etype (Pref);
Ityp : Entity_Id;
Xnum : Uint;
if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
Ityp := Get_Index_Subtype (N);
- -- If the index type, Ityp, is an enumeration type with
- -- holes, then we calculate X'Length explicitly using
+ -- If the index type, Ityp, is an enumeration type with holes,
+ -- then we calculate X'Length explicitly using
-- Typ'Max
-- (0, Ityp'Pos (X'Last (N)) -
-- Ityp'Pos (X'First (N)) + 1);
- -- Since the bounds in the template are the representation
- -- values and gigi would get the wrong value.
+ -- Since the bounds in the template are the representation values
+ -- and the back end would get the wrong value.
if Is_Enumeration_Type (Ityp)
and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
-- If the prefix type is a constrained packed array type which
-- already has a Packed_Array_Type representation defined, then
-- replace this attribute with a direct reference to 'Range_Length
- -- of the appropriate index subtype (since otherwise Gigi will try
- -- to give us the value of 'Length for this implementation type).
+ -- of the appropriate index subtype (since otherwise the back end
+ -- will try to give us the value of 'Length for this
+ -- implementation type).
elsif Is_Constrained (Ptyp) then
Rewrite (N,
Analyze_And_Resolve (N, Typ);
end if;
- -- If we have a packed array that is not bit packed, which was
-
-- Access type case
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
- -- If the designated type is a packed array type, then we
- -- convert the reference to:
+ -- If the designated type is a packed array type, then we convert
+ -- the reference to:
-- typ'Max (0, 1 +
-- xtyp'Pos (Pref'Last (Expr)) -
-- xtyp'Pos (Pref'First (Expr)));
- -- This is a bit complex, but it is the easiest thing to do
- -- that works in all cases including enum types with holes
- -- xtyp here is the appropriate index type.
+ -- This is a bit complex, but it is the easiest thing to do that
+ -- works in all cases including enum types with holes xtyp here
+ -- is the appropriate index type.
declare
Dtyp : constant Entity_Id := Designated_Type (Ptyp);
end if;
end;
- -- Otherwise leave it to gigi
+ -- Otherwise leave it to the back end
else
Apply_Universal_Integer_Attribute_Checks (N);
------------------
-- Machine_Size is equivalent to Object_Size, so transform it into
- -- Object_Size and that way Gigi never sees Machine_Size.
+ -- Object_Size and that way the back end never sees Machine_Size.
when Attribute_Machine_Size =>
Rewrite (N,
--------------
-- The only case that can get this far is the dynamic case of the old
- -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we
- -- expand:
+ -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
+ -- we expand:
-- typ'Mantissa
-- (Integer'Integer_Value (typ'First),
-- Integer'Integer_Value (typ'Last)));
- when Attribute_Mantissa => Mantissa : declare
- Ptyp : constant Entity_Id := Etype (Pref);
-
- begin
+ when Attribute_Mantissa => Mantissa : begin
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Asn_Stm : Node_Id;
begin
+ -- Find the nearest subprogram body, ignoring _Preconditions
+
Subp := N;
loop
Subp := Parent (Subp);
- exit when Nkind (Subp) = N_Subprogram_Body;
+ exit when Nkind (Subp) = N_Subprogram_Body
+ and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
end loop;
+ -- Insert the assignment at the start of the declarations
+
Asn_Stm :=
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
---------
-- For enumeration types with a standard representation, Pos is
- -- handled by Gigi.
+ -- handled by the back end.
-- For enumeration types, with a non-standard representation we
-- generate a call to the _Rep_To_Pos function created when the
-- Position --
--------------
- -- We compute this if a component clause was present, otherwise
- -- we leave the computation up to Gigi, since we don't know what
- -- layout will be chosen.
+ -- We compute this if a component clause was present, otherwise we leave
+ -- the computation up to the back end, since we don't know what layout
+ -- will be chosen.
when Attribute_Position => Position :
declare
when Attribute_Pred => Pred :
declare
- Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
+ Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
+
-- For enumeration types with non-standard representations, we
-- expand typ'Pred (x) into
-- If the representation is contiguous, we compute instead
-- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
+ -- The conversion function Enum_Pos_To_Rep is defined on the
+ -- base type, not the subtype, so we have to use the base type
+ -- explicitly for this and other enumeration attributes.
if Is_Enumeration_Type (Ptyp)
- and then Present (Enum_Pos_To_Rep (Ptyp))
+ and then Present (Enum_Pos_To_Rep (Etyp))
then
- if Has_Contiguous_Rep (Ptyp) then
+ if Has_Contiguous_Rep (Etyp) then
Rewrite (N,
Unchecked_Convert_To (Ptyp,
Make_Op_Add (Loc,
Make_Function_Call (Loc,
Name =>
New_Reference_To
- (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations =>
New_List (
Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
Rewrite (N,
Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Prefix =>
+ New_Reference_To
+ (Enum_Pos_To_Rep (Etyp), Loc),
Expressions => New_List (
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
- New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ New_Reference_To
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => Exprs),
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
end if;
New_Itype := Create_Itype (E_Access_Type, N);
Set_Etype (New_Itype, New_Itype);
- Init_Esize (New_Itype);
- Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype,
Corresponding_Record_Type (Conctyp));
Freeze_Itype (New_Itype, N);
-- Range_Length --
------------------
- when Attribute_Range_Length => Range_Length : declare
- P_Type : constant Entity_Id := Etype (Pref);
-
- begin
+ when Attribute_Range_Length => Range_Length : begin
-- The only special processing required is for the case where
-- Range_Length is applied to an enumeration type with holes.
-- In this case we transform
-- So that the result reflects the proper Pos values instead
-- of the underlying representations.
- if Is_Enumeration_Type (P_Type)
- and then Has_Non_Standard_Rep (P_Type)
+ if Is_Enumeration_Type (Ptyp)
+ and then Has_Non_Standard_Rep (Ptyp)
then
Rewrite (N,
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (P_Type, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Occurrence_Of (P_Type, Loc)))),
+ Prefix => New_Occurrence_Of (Ptyp, Loc)))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (P_Type, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (P_Type, Loc))))),
+ Prefix => New_Occurrence_Of (Ptyp, Loc))))),
Right_Opnd =>
Make_Integer_Literal (Loc, 1)));
Analyze_And_Resolve (N, Typ);
- -- For all other cases, attribute is handled by Gigi, but we need
- -- to deal with the case of the range check on a universal integer.
+ -- For all other cases, the attribute is handled by the back end, but
+ -- we need to deal with the case of the range check on a universal
+ -- integer.
else
Apply_Universal_Integer_Attribute_Checks (N);
when Attribute_Remainder =>
Expand_Fpt_Attribute_RR (N);
+ ------------
+ -- Result --
+ ------------
+
+ -- Transform 'Result into reference to _Result formal. At the point
+ -- where a legal 'Result attribute is expanded, we know that we are in
+ -- the context of a _Postcondition function with a _Result parameter.
+
+ when Attribute_Result =>
+ Rewrite (N,
+ Make_Identifier (Loc,
+ Chars => Name_uResult));
+ Analyze_And_Resolve (N, Typ);
+
-----------
-- Round --
-----------
Attribute_VADS_Size => Size :
declare
- Ptyp : constant Entity_Id := Etype (Pref);
Siz : Uint;
New_Node : Node_Id;
else
if (not Is_Entity_Name (Pref)
or else not Is_Type (Entity (Pref)))
- and then (Is_Scalar_Type (Etype (Pref))
- or else Is_Constrained (Etype (Pref)))
+ and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
then
- Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc));
+ Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
end if;
-- For a scalar type for which no size was explicitly given,
-- VADS_Size means Object_Size. This is the other respect in
-- which VADS_Size differs from Size.
- if Is_Scalar_Type (Etype (Pref))
- and then No (Size_Clause (Etype (Pref)))
- then
+ if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
Set_Attribute_Name (N, Name_Object_Size);
-- In all other cases, Size and VADS_Size are the sane
end if;
end if;
- -- For class-wide types, X'Class'Size is transformed into a
- -- direct reference to the Size of the class type, so that gigi
- -- does not have to deal with the X'Class'Size reference.
+ -- For class-wide types, X'Class'Size is transformed into a direct
+ -- reference to the Size of the class type, so that the back end does
+ -- not have to deal with the X'Class'Size reference.
if Is_Entity_Name (Pref)
and then Is_Class_Wide_Type (Entity (Pref))
end if;
end;
- -- All other cases are handled by Gigi
+ -- All other cases are handled by the back end
else
Apply_Universal_Integer_Attribute_Checks (N);
if Is_Entity_Name (Pref)
and then Is_Formal (Entity (Pref))
- and then Is_Array_Type (Etype (Pref))
- and then Is_Packed (Etype (Pref))
+ and then Is_Array_Type (Ptyp)
+ and then Is_Packed (Ptyp)
then
Rewrite (N,
Make_Attribute_Reference (Loc,
end if;
-- If Size applies to a dereference of an access to unconstrained
- -- packed array, GIGI needs to see its unconstrained nominal type,
- -- but also a hint to the actual constrained type.
+ -- packed array, the back end needs to see its unconstrained
+ -- nominal type, but also a hint to the actual constrained type.
if Nkind (Pref) = N_Explicit_Dereference
- and then Is_Array_Type (Etype (Pref))
- and then not Is_Constrained (Etype (Pref))
- and then Is_Packed (Etype (Pref))
+ and then Is_Array_Type (Ptyp)
+ and then not Is_Constrained (Ptyp)
+ and then Is_Packed (Ptyp)
then
Set_Actual_Designated_Subtype (Pref,
Get_Actual_Subtype (Pref));
-- Storage_Size --
------------------
- when Attribute_Storage_Size => Storage_Size :
- declare
- Ptyp : constant Entity_Id := Etype (Pref);
+ when Attribute_Storage_Size => Storage_Size : begin
- begin
-- Access type case, always go to the root type
-- The case of access types results in a value of zero for the case
-----------------
when Attribute_Stream_Size => Stream_Size : declare
- Ptyp : constant Entity_Id := Etype (Pref);
Size : Int;
begin
when Attribute_Succ => Succ :
declare
- Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
+ Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
+
-- For enumeration types with non-standard representations, we
-- expand typ'Succ (x) into
-- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
if Is_Enumeration_Type (Ptyp)
- and then Present (Enum_Pos_To_Rep (Ptyp))
+ and then Present (Enum_Pos_To_Rep (Etyp))
then
- if Has_Contiguous_Rep (Ptyp) then
+ if Has_Contiguous_Rep (Etyp) then
Rewrite (N,
Unchecked_Convert_To (Ptyp,
Make_Op_Add (Loc,
Make_Function_Call (Loc,
Name =>
New_Reference_To
- (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations =>
New_List (
Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
Rewrite (N,
Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Prefix =>
+ New_Reference_To
+ (Enum_Pos_To_Rep (Etyp), Loc),
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To
- (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => Exprs),
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
end if;
Ttyp := Entity (Pref);
Prefix_Is_Type := True;
else
- Ttyp := Etype (Pref);
+ Ttyp := Ptyp;
Prefix_Is_Type := False;
end if;
-- terminated (Task_Id (Pref._disp_get_task_id));
if Ada_Version >= Ada_05
- and then Ekind (Etype (Pref)) = E_Class_Wide_Type
- and then Is_Interface (Etype (Pref))
- and then Is_Task_Interface (Etype (Pref))
+ and then Ekind (Ptyp) = E_Class_Wide_Type
+ and then Is_Interface (Ptyp)
+ and then Is_Task_Interface (Ptyp)
then
Rewrite (N,
Make_Function_Call (Loc,
---------
-- For enumeration types with a standard representation, and for all
- -- other types, Val is handled by Gigi. For enumeration types with
- -- a non-standard representation we use the _Pos_To_Rep array that
+ -- other types, Val is handled by the back end. For enumeration types
+ -- with a non-standard representation we use the _Pos_To_Rep array that
-- was created when the type was frozen.
when Attribute_Val => Val :
when Attribute_Valid => Valid :
declare
- Ptyp : constant Entity_Id := Etype (Pref);
- Btyp : Entity_Id := Base_Type (Ptyp);
+ Btyp : Entity_Id := Base_Type (Ptyp);
Tst : Node_Id;
Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
-- Non VAX float case
else
- Find_Fat_Info (Etype (Pref), Ftp, Pkg);
+ Find_Fat_Info (Ptyp, Ftp, Pkg);
-- If the floating-point object might be unaligned, we need
-- to call the special routine Unaligned_Valid, which makes
Rewrite_Stream_Proc_Call (Pname);
end Write;
- -- Component_Size is handled by Gigi, unless the component size is known
- -- at compile time, which is always true in the packed array case. It is
- -- important that the packed array case is handled in the front end (see
- -- Eval_Attribute) since Gigi would otherwise get confused by the
- -- equivalent packed array type.
+ -- Component_Size is handled by the back end, unless the component size
+ -- is known at compile time, which is always true in the packed array
+ -- case. It is important that the packed array case is handled in the
+ -- front end (see Eval_Attribute) since the back end would otherwise get
+ -- confused by the equivalent packed array type.
when Attribute_Component_Size =>
null;
-- static cases have already been evaluated during semantic processing,
-- but in any case the back end should not count on this).
- -- Gigi also handles the non-class-wide cases of Size
+ -- The back end also handles the non-class-wide cases of Size
when Attribute_Bit_Order |
Attribute_Code_Address |
Attribute_Pool_Address =>
null;
- -- The following attributes are also handled by Gigi, but return a
- -- universal integer result, so may need a conversion for checking
+ -- The following attributes are also handled by the back end, but return
+ -- a universal integer result, so may need a conversion for checking
-- that the result is in range.
when Attribute_Aft |
Attribute_Fast_Math |
Attribute_Has_Access_Values |
Attribute_Has_Discriminants |
+ Attribute_Has_Tagged_Values |
Attribute_Large |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
raise Program_Error;
-- The Asm_Input and Asm_Output attributes are not expanded at this
- -- stage, but will be eliminated in the expansion of the Asm call,
- -- see Exp_Intr for details. So Gigi will never see these either.
+ -- stage, but will be eliminated in the expansion of the Asm call, see
+ -- Exp_Intr for details. So the back end will never see these either.
when Attribute_Asm_Input |
Attribute_Asm_Output =>
Nam : TSS_Name_Type) return Entity_Id
is
Ent : constant Entity_Id := TSS (Typ, Nam);
+
begin
if Present (Ent) then
return Ent;
end if;
+ -- Stream attributes for strings are expanded into library calls. The
+ -- following checks are disabled when the run-time is not available or
+ -- when compiling predefined types due to bootstrap issues. As a result,
+ -- the compiler will generate in-place stream routines for string types
+ -- that appear in GNAT's library, but will generate calls via rtsfind
+ -- to library routines for user code.
+ -- ??? For now, disable this code for JVM, since this generates a
+ -- VerifyError exception at run-time on e.g. c330001.
+ -- This is disabled for AAMP, to avoid making dependences on files not
+ -- supported in the AAMP library (such as s-fileio.adb).
+
+ if VM_Target /= JVM_Target
+ and then not AAMP_On_Target
+ and then
+ not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ then
+
+ -- String as defined in package Ada
+
+ if Typ = Standard_String then
+ if Nam = TSS_Stream_Input then
+ return RTE (RE_String_Input);
+
+ elsif Nam = TSS_Stream_Output then
+ return RTE (RE_String_Output);
+
+ elsif Nam = TSS_Stream_Read then
+ return RTE (RE_String_Read);
+
+ else pragma Assert (Nam = TSS_Stream_Write);
+ return RTE (RE_String_Write);
+ end if;
+
+ -- Wide_String as defined in package Ada
+
+ elsif Typ = Standard_Wide_String then
+ if Nam = TSS_Stream_Input then
+ return RTE (RE_Wide_String_Input);
+
+ elsif Nam = TSS_Stream_Output then
+ return RTE (RE_Wide_String_Output);
+
+ elsif Nam = TSS_Stream_Read then
+ return RTE (RE_Wide_String_Read);
+
+ else pragma Assert (Nam = TSS_Stream_Write);
+ return RTE (RE_Wide_String_Write);
+ end if;
+
+ -- Wide_Wide_String as defined in package Ada
+
+ elsif Typ = Standard_Wide_Wide_String then
+ if Nam = TSS_Stream_Input then
+ return RTE (RE_Wide_Wide_String_Input);
+
+ elsif Nam = TSS_Stream_Output then
+ return RTE (RE_Wide_Wide_String_Output);
+
+ elsif Nam = TSS_Stream_Read then
+ return RTE (RE_Wide_Wide_String_Read);
+
+ else pragma Assert (Nam = TSS_Stream_Write);
+ return RTE (RE_Wide_Wide_String_Write);
+ end if;
+ end if;
+ end if;
+
if Is_Tagged_Type (Typ)
and then Is_Derived_Type (Typ)
then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
Id : Entity_Id := Entity (Name (N));
begin
+ Name_Len := 0;
Build_Location_String (Loc);
-- If the exception is a renaming, use the exception that it
-- statements.
procedure Expand_Simple_Function_Return (N : Node_Id);
- -- Expand simple return from function. Called by
- -- Expand_N_Simple_Return_Statement in case we're returning from a function
- -- body.
+ -- Expand simple return from function. In the case where we are returning
+ -- from a function body this is called by Expand_N_Simple_Return_Statement.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and tagged assignment,
-- return not (expression);
- if Nkind (N) = N_If_Statement
- and then No (Elsif_Parts (N))
- and then Present (Else_Statements (N))
- and then List_Length (Then_Statements (N)) = 1
- and then List_Length (Else_Statements (N)) = 1
- then
- declare
- Then_Stm : constant Node_Id := First (Then_Statements (N));
- Else_Stm : constant Node_Id := First (Else_Statements (N));
+ -- Only do these optimizations if we are at least at -O1 level
- begin
- if Nkind (Then_Stm) = N_Simple_Return_Statement
- and then
- Nkind (Else_Stm) = N_Simple_Return_Statement
- then
- declare
- Then_Expr : constant Node_Id := Expression (Then_Stm);
- Else_Expr : constant Node_Id := Expression (Else_Stm);
+ if Optimization_Level > 0 then
+ if Nkind (N) = N_If_Statement
+ and then No (Elsif_Parts (N))
+ and then Present (Else_Statements (N))
+ and then List_Length (Then_Statements (N)) = 1
+ and then List_Length (Else_Statements (N)) = 1
+ then
+ declare
+ Then_Stm : constant Node_Id := First (Then_Statements (N));
+ Else_Stm : constant Node_Id := First (Else_Statements (N));
- begin
- if Nkind (Then_Expr) = N_Identifier
- and then
- Nkind (Else_Expr) = N_Identifier
- then
- if Entity (Then_Expr) = Standard_True
- and then Entity (Else_Expr) = Standard_False
- then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression => Relocate_Node (Condition (N))));
- Analyze (N);
- return;
-
- elsif Entity (Then_Expr) = Standard_False
- and then Entity (Else_Expr) = Standard_True
+ begin
+ if Nkind (Then_Stm) = N_Simple_Return_Statement
+ and then
+ Nkind (Else_Stm) = N_Simple_Return_Statement
+ then
+ declare
+ Then_Expr : constant Node_Id := Expression (Then_Stm);
+ Else_Expr : constant Node_Id := Expression (Else_Stm);
+
+ begin
+ if Nkind (Then_Expr) = N_Identifier
+ and then
+ Nkind (Else_Expr) = N_Identifier
then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Op_Not (Loc,
- Right_Opnd => Relocate_Node (Condition (N)))));
- Analyze (N);
- return;
+ if Entity (Then_Expr) = Standard_True
+ and then Entity (Else_Expr) = Standard_False
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Relocate_Node (Condition (N))));
+ Analyze (N);
+ return;
+
+ elsif Entity (Then_Expr) = Standard_False
+ and then Entity (Else_Expr) = Standard_True
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Relocate_Node (Condition (N)))));
+ Analyze (N);
+ return;
+ end if;
end if;
- end if;
- end;
- end if;
- end;
+ end;
+ end if;
+ end;
+ end if;
end if;
end Expand_N_If_Statement;
procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
begin
+ -- Defend agains previous errors (ie. the return statement calls a
+ -- function that is not available in configurable runtime).
+
+ if Present (Expression (N))
+ and then Nkind (Expression (N)) = N_Empty
+ then
+ return;
+ end if;
+
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
Lab_Node : Node_Id;
begin
+ -- Call postconditions procedure if procedure with active postconditions
+
+ if Ekind (Scope_Id) = E_Procedure
+ and then Has_Postconditions (Scope_Id)
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uPostconditions)));
+ end if;
+
-- If it is a return from a procedure do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then
elsif Is_Protected_Type (Scope_Id) then
Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Complete_Entry_Body), Loc),
- Parameter_Associations => New_List
- (Make_Attribute_Reference (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Complete_Entry_Body), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
- (Object_Ref
- (Corresponding_Body (Parent (Scope_Id))),
- Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ (Find_Protection_Object (Current_Scope), Loc),
+ Attribute_Name =>
+ Name_Unchecked_Access)));
Insert_Before (N, Call);
Analyze (Call);
-- The type of the expression (not necessarily the same as R_Type)
begin
- -- We rewrite "return <expression>;" to be:
+ -- For the case of a simple return that does not come from an extended
+ -- return, in the case of Ada 2005 where we are returning a limited
+ -- type, we rewrite "return <expression>;" to be:
-- return _anon_ : <return_subtype> := <expression>
-- The expansion produced by Expand_N_Extended_Return_Statement will
-- contain simple return statements (for example, a block containing
-- simple return of the return object), which brings us back here with
- -- Comes_From_Extended_Return_Statement set. To avoid infinite
- -- recursion, we do not transform into an extended return if
- -- Comes_From_Extended_Return_Statement is True.
+ -- Comes_From_Extended_Return_Statement set. The reason for the barrier
+ -- checking for a simple return that does not come from an extended
+ -- return is to avoid this infinite recursion.
-- The reason for this design is that for Ada 2005 limited returns, we
-- need to reify the return object, so we can build it "in place", and
-- we need a block statement to hang finalization and tasking stuff.
-- ??? In order to avoid disruption, we avoid translating to extended
- -- return except in the cases where we really need to (Ada 2005
- -- inherently limited). We would prefer eventually to do this
- -- translation in all cases except perhaps for the case of Ada 95
- -- inherently limited, in order to fully exercise the code in
- -- Expand_N_Extended_Return_Statement, and in order to do
- -- build-in-place for efficiency when it is not required.
+ -- return except in the cases where we really need to (Ada 2005 for
+ -- inherently limited). We might prefer to do this translation in all
+ -- cases (except perhaps for the case of Ada 95 inherently limited),
+ -- in order to fully exercise the Expand_N_Extended_Return_Statement
+ -- code. This would also allow us to to the build-in-place optimization
+ -- for efficiency even in cases where it is semantically not required.
-- As before, we check the type of the return expression rather than the
-- return type of the function, because the latter may be a limited
if not Comes_From_Extended_Return_Statement (N)
and then Is_Inherently_Limited_Type (Etype (Expression (N)))
- and then Ada_Version >= Ada_05 -- ???
+ and then Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
then
declare
-- secondary stack.
else
- Set_Storage_Pool (N, RTE (RE_SS_Pool));
+ Set_Storage_Pool (N, RTE (RE_SS_Pool));
-- If we are generating code for the VM do not use
-- SS_Allocate since everything is heap-allocated anyway.
Reason => PE_Accessibility_Check_Failed));
end;
end if;
+
+ -- Generate call to postcondition checks if they are present
+
+ if Ekind (Scope_Id) = E_Function
+ and then Has_Postconditions (Scope_Id)
+ then
+ -- We are going to reference the returned value twice in this case,
+ -- once in the call to _Postconditions, and once in the actual return
+ -- statement, but we can't have side effects happening twice, and in
+ -- any case for efficiency we don't want to do the computation twice.
+
+ -- If the returned expression is an entity name, we don't need to
+ -- worry since it is efficient and safe to reference it twice, that's
+ -- also true for literals other than string literals, and for the
+ -- case of X.all where X is an entity name.
+
+ if Is_Entity_Name (Exp)
+ or else Nkind_In (Exp, N_Character_Literal,
+ N_Integer_Literal,
+ N_Real_Literal)
+ or else (Nkind (Exp) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Exp)))
+ then
+ null;
+
+ -- Otherwise we are going to need a temporary to capture the value
+
+ else
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T'));
+
+ begin
+ -- For a complex expression of an elementary type, capture
+ -- value in the temporary and use it as the reference.
+
+ if Is_Elementary_Type (R_Type) then
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (R_Type, Loc),
+ Expression => Relocate_Node (Exp)),
+ Suppress => All_Checks);
+
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+
+ -- If we have something we can rename, generate a renaming of
+ -- the object and replace the expression with a reference
+
+ elsif Is_Object_Reference (Exp) then
+ Insert_Action (Exp,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Subtype_Mark => New_Occurrence_Of (R_Type, Loc),
+ Name => Relocate_Node (Exp)),
+ Suppress => All_Checks);
+
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+
+ -- Otherwise we have something like a string literal or an
+ -- aggregate. We could copy the value, but that would be
+ -- inefficient. Instead we make a reference to the value and
+ -- capture this reference with a renaming, the expression is
+ -- then replaced by a dereference of this renaming.
+
+ else
+ -- For now, copy the value, since the code below does not
+ -- seem to work correctly ???
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (R_Type, Loc),
+ Expression => Relocate_Node (Exp)),
+ Suppress => All_Checks);
+
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+
+ -- Insert_Action (Exp,
+ -- Make_Object_Renaming_Declaration (Loc,
+ -- Defining_Identifier => Tnn,
+ -- Access_Definition =>
+ -- Make_Access_Definition (Loc,
+ -- All_Present => True,
+ -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)),
+ -- Name =>
+ -- Make_Reference (Loc,
+ -- Prefix => Relocate_Node (Exp))),
+ -- Suppress => All_Checks);
+
+ -- Rewrite (Exp,
+ -- Make_Explicit_Dereference (Loc,
+ -- Prefix => New_Occurrence_Of (Tnn, Loc)));
+ end if;
+ end;
+ end if;
+
+ -- Generate call to _postconditions
+
+ Insert_Action (Exp,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Make_Identifier (Loc, Name_uPostconditions),
+ Parameter_Associations => New_List (Duplicate_Subexpr (Exp))));
+ end if;
end Expand_Simple_Function_Return;
------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- String cases
else
+ Name_Len := 0;
+
case Nam is
when Name_File =>
Get_Decoded_Name_String
Build_Location_String (Loc);
when Name_Enclosing_Entity =>
- Name_Len := 0;
-
- Ent := Current_Scope;
-- Skip enclosing blocks to reach enclosing unit
+ Ent := Current_Scope;
while Present (Ent) loop
exit when Ekind (Ent) /= E_Block
and then Ekind (Ent) /= E_Loop;
-- Ent now points to the relevant defining entity
- Name_Len := 0;
Write_Entity_Name (Ent);
when others =>
end case;
Rewrite (N,
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
Analyze_And_Resolve (N, Standard_String);
end if;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
-with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
function Arg1 (N : Node_Id) return Node_Id;
function Arg2 (N : Node_Id) return Node_Id;
+ function Arg3 (N : Node_Id) return Node_Id;
-- Obtain specified pragma argument expression
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
- procedure Expand_Pragma_Assert (N : Node_Id);
+ procedure Expand_Pragma_Check (N : Node_Id);
procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import_Or_Interface (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Expand_Pragma_Psect_Object (N : Node_Id);
+ procedure Expand_Pragma_Relative_Deadline (N : Node_Id);
----------
-- Arg1 --
function Arg2 (N : Node_Id) return Node_Id is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+
begin
if No (Arg1) then
return Empty;
+
else
declare
Arg : constant Node_Id := Next (Arg1);
end if;
end Arg2;
+ ----------
+ -- Arg3 --
+ ----------
+
+ function Arg3 (N : Node_Id) return Node_Id is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+
+ begin
+ if No (Arg1) then
+ return Empty;
+
+ else
+ declare
+ Arg : Node_Id := Next (Arg1);
+ begin
+ if No (Arg) then
+ return Empty;
+
+ else
+ Next (Arg);
+
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end if;
+ end;
+ end if;
+ end Arg3;
+
---------------------
-- Expand_N_Pragma --
---------------------
when Pragma_Abort_Defer =>
Expand_Pragma_Abort_Defer (N);
- when Pragma_Assert =>
- Expand_Pragma_Assert (N);
+ when Pragma_Check =>
+ Expand_Pragma_Check (N);
when Pragma_Common_Object =>
Expand_Pragma_Common_Object (N);
when Pragma_Psect_Object =>
Expand_Pragma_Psect_Object (N);
+ when Pragma_Relative_Deadline =>
+ Expand_Pragma_Relative_Deadline (N);
+
-- All other pragmas need no expander action
when others => null;
end Expand_Pragma_Abort_Defer;
--------------------------
- -- Expand_Pragma_Assert --
+ -- Expand_Pragma_Check --
--------------------------
- procedure Expand_Pragma_Assert (N : Node_Id) is
+ procedure Expand_Pragma_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Cond : constant Node_Id := Arg1 (N);
- Msg : String_Id;
+ Cond : constant Node_Id := Arg2 (N);
+ Nam : constant Name_Id := Chars (Arg1 (N));
+ Msg : Node_Id;
begin
- -- We already know that assertions are enabled, because otherwise
- -- the semantic pass dealt with rewriting the assertion (see Sem_Prag)
-
- pragma Assert (Assertions_Enabled);
+ -- We already know that this check is enabled, because otherwise the
+ -- semantic pass dealt with rewriting the assertion (see Sem_Prag)
- -- Since assertions are on, we rewrite the pragma with its
+ -- Since this check is enabled, we rewrite the pragma into a
-- corresponding if statement, and then analyze the statement
+
-- The normal case expansion transforms:
- -- pragma Assert (condition [,message]);
+ -- pragma Check (name, condition [,message]);
-- into
-- end if;
-- where Str is the message if one is present, or the default of
- -- file:line if no message is given.
+ -- name failed at file:line if no message is given (the "name failed
+ -- at" is omitted for name = Assertion, since it is redundant, given
+ -- that the name of the exception is Assert_Failure.
-- An alternative expansion is used when the No_Exception_Propagation
-- restriction is active and there is a local Assert_Failure handler.
-- Case where we generate a direct raise
if (Debug_Flag_Dot_G
- or else Restriction_Active (No_Exception_Propagation))
+ or else Restriction_Active (No_Exception_Propagation))
and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))
then
Rewrite (N,
-- Case where we call the procedure
else
- -- First, we need to prepare the string literal
+ -- First, we need to prepare the string argument
+
+ -- If we have a message given, use it
+
+ if Present (Arg3 (N)) then
+ Msg := Arg3 (N);
+
+ -- Otherwise string is "name failed at location" except in the case
+ -- of Assertion where "name failed at" is omitted.
- if Present (Arg2 (N)) then
- Msg := Strval (Expr_Value_S (Arg2 (N)));
else
+ if Nam = Name_Assertion then
+ Name_Len := 0;
+ else
+ Get_Name_String (Nam);
+ Set_Casing (Identifier_Casing (Current_Source_File));
+ Add_Str_To_Name_Buffer (" failed at ");
+ end if;
+
Build_Location_String (Loc);
- Msg := String_From_Name_Buffer;
+ Msg :=
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer);
end if;
-- Now rewrite as an if statement
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, Msg))))));
+ Parameter_Associations => New_List (Msg)))));
end if;
Analyze (N);
and then Entity (Original_Node (Cond)) = Standard_False
then
return;
- else
+ elsif Nam = Name_Assertion then
Error_Msg_N ("?assertion will fail at run-time", N);
+ else
+ Error_Msg_N ("?check will fail at run time", N);
end if;
end if;
- end Expand_Pragma_Assert;
+ end Expand_Pragma_Check;
---------------------------------
-- Expand_Pragma_Common_Object --
procedure Expand_Pragma_Psect_Object (N : Node_Id)
renames Expand_Pragma_Common_Object;
+ -------------------------------------
+ -- Expand_Pragma_Relative_Deadline --
+ -------------------------------------
+
+ procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
+ P : constant Node_Id := Parent (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ -- Expand the pragma only in the case of the main subprogram. For tasks
+ -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
+ -- at Clock plus the relative deadline specified in the pragma. Time
+ -- values are translated into Duration to allow for non-private
+ -- addition operation.
+
+ if Nkind (P) = N_Subprogram_Body then
+ Rewrite
+ (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Set_Deadline), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RO_RT_Time),
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ New_Reference_To (RTE (RO_RT_To_Duration), Loc),
+ New_List (Make_Function_Call (Loc,
+ New_Reference_To (RTE (RE_Clock), Loc)))),
+ Right_Opnd =>
+ Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
+
+ Analyze (N);
+ end if;
+ end Expand_Pragma_Relative_Deadline;
+
end Exp_Prag;
with Sprint;
with Scn; use Scn;
with Sem; use Sem;
+with Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Elab; use Sem_Elab;
with Sem_Prag; use Sem_Prag;
Nlists.Initialize;
Elists.Initialize;
Lib.Load.Initialize;
+ Sem_Aux.Initialize;
Sem_Ch8.Initialize;
+ Sem_Prag.Initialize;
Fname.UF.Initialize;
Checks.Initialize;
Sem_Warn.Initialize;
Pragma_Atomic |
Pragma_Atomic_Components |
Pragma_Attach_Handler |
+ Pragma_Check |
Pragma_Check_Name |
+ Pragma_Check_Policy |
Pragma_CIL_Constructor |
Pragma_Compile_Time_Error |
Pragma_Compile_Time_Warning |
Pragma_Preelaborable_Initialization |
Pragma_Polling |
Pragma_Persistent_BSS |
+ Pragma_Postcondition |
+ Pragma_Precondition |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |
Pragma_Pure_05 |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
+ Pragma_Relative_Deadline |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restricted_Run_Time |
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
procedure Check_Enum_Image;
-- If the prefix type is an enumeration type, set all its literals
-- as referenced, since the image function could possibly end up
- -- referencing any of the literals indirectly.
+ -- referencing any of the literals indirectly. Same for Enum_Val.
procedure Check_Fixed_Point_Type;
-- Verify that prefix of attribute N is a fixed type
-- two attribute expressions are present
procedure Legal_Formal_Attribute;
- -- Common processing for attributes Definite, Has_Access_Values,
- -- and Has_Discriminants
+ -- Common processing for attributes Definite and Has_Discriminants.
+ -- Checks that prefix is generic indefinite formal type.
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
procedure Check_Modular_Integer_Type;
-- Verify that prefix of attribute N is a modular integer type
+ procedure Check_Not_CPP_Type;
+ -- Check that P (the prefix of the attribute) is not an CPP type
+ -- for which no Ada predefined primitive is available.
+
procedure Check_Not_Incomplete_Type;
-- Check that P (the prefix of the attribute) is not an incomplete
-- type or a private type for which no full view has been given.
-- type that is constructed is returned as the result.
procedure Build_Access_Subprogram_Type (P : Node_Id);
- -- Build an access to subprogram whose designated type is
- -- the type of the prefix. If prefix is overloaded, so it the
- -- node itself. The result is stored in Acc_Type.
+ -- Build an access to subprogram whose designated type is the type of
+ -- the prefix. If prefix is overloaded, so is the node itself. The
+ -- result is stored in Acc_Type.
function OK_Self_Reference return Boolean;
-- An access reference whose prefix is a type can legally appear
(E_Access_Attribute_Type, Current_Scope, Loc, 'A');
begin
Set_Etype (Typ, Typ);
- Init_Size_Align (Typ);
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, N);
Set_Directly_Designated_Type (Typ, DT);
if Aname = Name_Unrestricted_Access then
-- Do not kill values on nodes initializing dispatch tables
- -- slots. The construct Address!(Prim'Unrestricted_Access)
+ -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
-- is currently generated by the expander only for this
-- purpose. Done to keep the quality of warnings currently
-- generated by the compiler (otherwise any declaration of
-- a tagged type cleans constant indications from its scope).
if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then Etype (Parent (N)) = RTE (RE_Address)
+ and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ or else
+ Etype (Parent (N)) = RTE (RE_Size_Ptr))
and then Is_Dispatching_Operation
(Directly_Designated_Type (Etype (N)))
then
("current instance prefix must be a direct name", P);
end if;
- -- If a current instance attribute appears within a
- -- a component constraint it must appear alone; other
- -- contexts (default expressions, within a task body)
- -- are not subject to this restriction.
+ -- If a current instance attribute appears in a component
+ -- constraint it must appear alone; other contexts (spec-
+ -- expressions, within a task body) are not subject to this
+ -- restriction.
- if not In_Default_Expression
+ if not In_Spec_Expression
and then not Has_Completion (Scop)
and then not
Nkind_In (Parent (N), N_Discriminant_Association,
end if;
end Check_Modular_Integer_Type;
+ ------------------------
+ -- Check_Not_CPP_Type --
+ ------------------------
+
+ procedure Check_Not_CPP_Type is
+ begin
+ if Is_Tagged_Type (Etype (P))
+ and then Convention (Etype (P)) = Convention_CPP
+ and then Is_CPP_Class (Root_Type (Etype (P)))
+ then
+ Error_Attr_P ("invalid use of % attribute with CPP tagged type");
+ end if;
+ end Check_Not_CPP_Type;
+
-------------------------------
-- Check_Not_Incomplete_Type --
-------------------------------
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
- or else In_Default_Expression
+ or else In_Spec_Expression
then
return;
else
Resolve (E2, P_Type);
end if;
+
+ Check_Not_CPP_Type;
end Check_Stream_Attribute;
-----------------------
and then Aname /= Name_Access
and then Aname /= Name_Address
and then Aname /= Name_Code_Address
+ and then Aname /= Name_Result
and then Aname /= Name_Unchecked_Access
then
-- Ada 2005 (AI-345): Since protected and task types have primitive
Check_E0;
Check_Not_Incomplete_Type;
+ Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
---------------
end if;
end if;
- Note_Possible_Modification (E2);
+ Note_Possible_Modification (E2, Sure => True);
Set_Etype (N, RTE (RE_Asm_Output_Operand));
---------------
-- is set True for the entry family case). In the True case,
-- makes sure that Is_AST_Entry is set on the entry.
+ -------------------
+ -- Bad_AST_Entry --
+ -------------------
+
procedure Bad_AST_Entry is
begin
Error_Attr_P ("prefix for % attribute must be task entry");
end Bad_AST_Entry;
+ --------------
+ -- OK_Entry --
+ --------------
+
function OK_Entry (E : Entity_Id) return Boolean is
Result : Boolean;
Set_Etype (N, Universal_Integer);
end Enum_Rep;
+ --------------
+ -- Enum_Val --
+ --------------
+
+ when Attribute_Enum_Val => Enum_Val : begin
+ Check_E1;
+ Check_Type;
+
+ if not Is_Enumeration_Type (P_Type) then
+ Error_Attr_P ("prefix of % attribute must be enumeration type");
+ end if;
+
+ -- If the enumeration type has a standard representation, the effect
+ -- is the same as 'Val, so rewrite the attribute as a 'Val.
+
+ if not Has_Non_Standard_Rep (P_Base_Type) then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (N)),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Relocate_Node (E1))));
+ Analyze_And_Resolve (N, P_Base_Type);
+
+ -- Non-standard representation case (enumeration with holes)
+
+ else
+ Check_Enum_Image;
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
+ end if;
+ end Enum_Val;
+
-------------
-- Epsilon --
-------------
Set_Etype (N, Standard_Boolean);
-----------------------
+ -- Has_Tagged_Values --
+ -----------------------
+
+ when Attribute_Has_Tagged_Values =>
+ Check_Type;
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ -----------------------
-- Has_Discriminants --
-----------------------
Set_Etype (N, P_Base_Type);
+ -------------------
+ -- Invalid_Value --
+ -------------------
+
+ when Attribute_Invalid_Value =>
+ Check_E0;
+ Check_Scalar_Type;
+ Set_Etype (N, P_Base_Type);
+ Invalid_Value_Used := True;
+
-----------
-- Large --
-----------
("(Ada 83) % attribute not allowed for scalar type", P);
end if;
+ ------------
+ -- Result --
+ ------------
+
+ when Attribute_Result => Result : declare
+ CS : constant Entity_Id := Current_Scope;
+ PS : constant Entity_Id := Scope (CS);
+
+ begin
+ -- If we are in the scope of a function and in Spec_Expression mode,
+ -- this is likely the prescan of the postcondition pragma, and we
+ -- just set the proper type. If there is an error it will be caught
+ -- when the real Analyze call is done.
+
+ if Ekind (CS) = E_Function
+ and then In_Spec_Expression
+ then
+ -- Check OK prefix
+
+ if Chars (CS) /= Chars (P) then
+ Error_Msg_NE
+ ("incorrect prefix for % attribute, expected &", P, CS);
+ Error_Attr;
+ end if;
+
+ Set_Etype (N, Etype (CS));
+
+ -- If several functions with that name are visible,
+ -- the intended one is the current scope.
+
+ if Is_Overloaded (P) then
+ Set_Entity (P, CS);
+ Set_Is_Overloaded (P, False);
+ end if;
+
+ -- Body case, where we must be inside a generated _Postcondition
+ -- procedure, or the attribute use is definitely misplaced.
+
+ elsif Chars (CS) = Name_uPostconditions
+ and then Ekind (PS) = E_Function
+ then
+ -- Check OK prefix
+
+ if Nkind (P) /= N_Identifier
+ or else Chars (P) /= Chars (PS)
+ then
+ Error_Msg_NE
+ ("incorrect prefix for % attribute, expected &", P, PS);
+ Error_Attr;
+ end if;
+
+ Rewrite (N,
+ Make_Identifier (Sloc (N),
+ Chars => Name_uResult));
+ Analyze_And_Resolve (N, Etype (PS));
+
+ else
+ Error_Attr
+ ("% attribute can only appear in function Postcondition pragma",
+ P);
+ end if;
+ end Result;
+
------------------
-- Range_Length --
------------------
Check_Stream_Attribute (TSS_Stream_Read);
Set_Etype (N, Standard_Void_Type);
Resolve (N, Standard_Void_Type);
- Note_Possible_Modification (E2);
+ Note_Possible_Modification (E2, Sure => True);
---------------
-- Remainder --
end if;
Check_Not_Incomplete_Type;
+ Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
end Size;
-- Definite must be folded if the prefix is not a generic type,
-- that is to say if we are within an instantiation. Same processing
-- applies to the GNAT attributes Has_Discriminants, Type_Class,
- -- and Unconstrained_Array.
+ -- Has_Tagged_Value, and Unconstrained_Array.
elsif (Id = Attribute_Definite
or else
or else
Id = Attribute_Has_Discriminants
or else
+ Id = Attribute_Has_Tagged_Values
+ or else
Id = Attribute_Type_Class
or else
Id = Attribute_Unconstrained_Array)
-- since we can't do anything with unconstrained arrays. In addition,
-- only the First, Last and Length attributes are possibly static.
- -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and
- -- Unconstrained_Array are again exceptions, because they apply as
- -- well to unconstrained types.
+ -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values,
+ -- Type_Class, and Unconstrained_Array are again exceptions, because
+ -- they apply as well to unconstrained types.
-- In addition Component_Size is an exception since it is possibly
-- foldable, even though it is never static, and it does apply to
or else
Id = Attribute_Has_Discriminants
or else
+ Id = Attribute_Has_Tagged_Values
+ or else
Id = Attribute_Type_Class
or else
Id = Attribute_Unconstrained_Array
Fold_Uint (N, Expr_Value (E1), Static);
end if;
+ --------------
+ -- Enum_Val --
+ --------------
+
+ when Attribute_Enum_Val => Enum_Val : declare
+ Lit : Node_Id;
+
+ begin
+ -- We have something like Enum_Type'Enum_Val (23), so search for a
+ -- corresponding value in the list of Enum_Rep values for the type.
+
+ Lit := First_Literal (P_Base_Type);
+ loop
+ if Enumeration_Rep (Lit) = Expr_Value (E1) then
+ Fold_Uint (N, Enumeration_Pos (Lit), Static);
+ exit;
+ end if;
+
+ Next_Literal (Lit);
+
+ if No (Lit) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "no representation value matches",
+ CE_Range_Check_Failed,
+ Warn => not Static);
+ exit;
+ end if;
+ end loop;
+ end Enum_Val;
+
-------------
-- Epsilon --
-------------
Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
+ -----------------------
+ -- Has_Tagged_Values --
+ -----------------------
+
+ when Attribute_Has_Tagged_Values =>
+ Rewrite (N, New_Occurrence_Of
+ (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
+
--------------
-- Identity --
--------------
-- Integer_Value --
-------------------
+ -- We never try to fold Integer_Value (though perhaps we could???)
+
when Attribute_Integer_Value =>
null;
+ -------------------
+ -- Invalid_Value --
+ -------------------
+
+ -- Invalid_Value is a scalar attribute that is never static, because
+ -- the value is by design out of range.
+
+ when Attribute_Invalid_Value =>
+ null;
+
-----------
-- Large --
-----------
else
declare
R : constant Entity_Id := Root_Type (P_Type);
- Lo : constant Uint :=
- Expr_Value (Type_Low_Bound (P_Type));
- Hi : constant Uint :=
- Expr_Value (Type_High_Bound (P_Type));
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
W : Nat;
Wt : Nat;
T : Uint;
-- Width for types derived from Standard.Character
-- and Standard.Wide_[Wide_]Character.
- elsif R = Standard_Character
- or else R = Standard_Wide_Character
- or else R = Standard_Wide_Wide_Character
- then
+ elsif Is_Standard_Character_Type (P_Type) then
W := 0;
-- Set W larger if needed
Attribute_Position |
Attribute_Priority |
Attribute_Read |
+ Attribute_Result |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
Access_Attribute :
begin
if Is_Variable (P) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
if Is_Entity_Name (P) then
-- If it is an object, complete its resolution.
elsif Is_Overloadable (Entity (P)) then
- if not In_Default_Expression then
+
+ -- Avoid insertion of freeze actions in spec expression mode
+
+ if not In_Spec_Expression then
Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
end if;
-- it may be modified via this address, so note modification.
if Is_Variable (P) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
if Nkind (P) in N_Subexpr
LB : Node_Id;
HB : Node_Id;
- function Check_Discriminated_Prival
- (N : Node_Id)
- return Node_Id;
- -- The range of a private component constrained by a
- -- discriminant is rewritten to make the discriminant
- -- explicit. This solves some complex visibility problems
- -- related to the use of privals.
-
- --------------------------------
- -- Check_Discriminated_Prival --
- --------------------------------
-
- function Check_Discriminated_Prival
- (N : Node_Id)
- return Node_Id
- is
- begin
- if Is_Entity_Name (N)
- and then Ekind (Entity (N)) = E_In_Parameter
- and then not Within_Init_Proc
- then
- return Make_Identifier (Sloc (N), Chars (Entity (N)));
- else
- return Duplicate_Subexpr (N);
- end if;
- end Check_Discriminated_Prival;
-
- -- Start of processing for Range_Attribute
-
begin
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
Resolve (P);
end if;
- -- Check whether prefix is (renaming of) private component
- -- of protected type.
+ HB :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (P, Name_Req => True),
+ Attribute_Name => Name_Last,
+ Expressions => Expressions (N));
- if Is_Entity_Name (P)
- and then Comes_From_Source (N)
- and then Is_Array_Type (Etype (P))
- and then Number_Dimensions (Etype (P)) = 1
- and then (Ekind (Scope (Entity (P))) = E_Protected_Type
- or else
- Ekind (Scope (Scope (Entity (P)))) =
- E_Protected_Type)
- then
- LB :=
- Check_Discriminated_Prival
- (Type_Low_Bound (Etype (First_Index (Etype (P)))));
-
- HB :=
- Check_Discriminated_Prival
- (Type_High_Bound (Etype (First_Index (Etype (P)))));
-
- else
- HB :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (P),
- Attribute_Name => Name_Last,
- Expressions => Expressions (N));
-
- LB :=
- Make_Attribute_Reference (Loc,
- Prefix => P,
- Attribute_Name => Name_First,
- Expressions => Expressions (N));
- end if;
+ LB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => P,
+ Attribute_Name => Name_First,
+ Expressions => Expressions (N));
-- If the original was marked as Must_Not_Freeze (see code
-- in Sem_Ch3.Make_Index), then make sure the rewriting
return;
end Range_Attribute;
+ ------------
+ -- Result --
+ ------------
+
+ -- We will only come here during the prescan of a spec expression
+ -- containing a Result attribute. In that case the proper Etype has
+ -- already been set, and nothing more needs to be done here.
+
+ when Attribute_Result =>
+ null;
+
-----------------
-- UET_Address --
-----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- absence of an enumeration representation clause. This is a static
-- attribute (i.e. the result is static if the argument is static).
+ --------------
+ -- Enum_Val --
+ --------------
+
+ Attribute_Enum_Val => True,
+ -- For every enumeration subtype S, S'Enum_Val denotes a function
+ -- with the following specification:
+ --
+ -- function S'Enum_Val (Arg : universal_integer) return S'Base;
+ --
+ -- This function performs the inverse transformation to Enum_Rep. Given
+ -- a representation value for the type, it returns the corresponding
+ -- enumeration value. Constraint_Error is raised if no value of the
+ -- enumeration type corresponds to the given integer value.
+
-----------------
-- Fixed_Value --
-----------------
-- attribute is primarily intended for use in implementation of the
-- standard input-output functions for fixed-point values.
+ Attribute_Invalid_Value => True,
+ -- For every scalar type, S'Invalid_Value designates an undefined value
+ -- of the type. If possible this value is an invalid value, and in fact
+ -- is identical to the value that would be set if Initialize_Scalars
+ -- mode were in effect (including the behavior of its value on
+ -- environment variables or binder switches). The intended use is
+ -- to set a value where intialization is required (e.g. as a result of
+ -- the coding standards in use), but logically no initialization is
+ -- needed, and the value should never be accessed.
+
------------------
-- Machine_Size --
------------------
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2008, 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 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Sem_Aux is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Obsolescent_Warnings.Init;
+ end Initialize;
+
+ ---------------
+ -- Tree_Read --
+ ---------------
+
+ procedure Tree_Read is
+ begin
+ Obsolescent_Warnings.Tree_Read;
+ end Tree_Read;
+
+ ----------------
+ -- Tree_Write --
+ ----------------
+
+ procedure Tree_Write is
+ begin
+ Obsolescent_Warnings.Tree_Write;
+ end Tree_Write;
+
+end Sem_Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S E M _ A U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2008, 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 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Package containing utility procedures used throughout the compiler,
+-- and also by ASIS so dependencies are limited to ASIS included packages.
+
+-- Note: contents are minimal for now, the intent is to move stuff from
+-- Sem_Util that meets the ASIS dependency requirements, and also stuff
+-- from Einfo, where Einfo had excessive semantic knowledge of the tree.
+
+with Alloc; use Alloc;
+with Table;
+with Types; use Types;
+
+package Sem_Aux is
+
+ --------------------------------
+ -- Obsolescent Warnings Table --
+ --------------------------------
+
+ -- This table records entities for which a pragma Obsolescent with a
+ -- message argument has been processed.
+
+ type OWT_Record is record
+ Ent : Entity_Id;
+ -- The entity to which the pragma applies
+
+ Msg : String_Id;
+ -- The string containing the message
+ end record;
+
+ package Obsolescent_Warnings is new Table.Table (
+ Table_Component_Type => OWT_Record,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Obsolescent_Warnings_Initial,
+ Table_Increment => Alloc.Obsolescent_Warnings_Increment,
+ Table_Name => "Obsolescent_Warnings");
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Initialize;
+ -- Called at the start of compilation of each new main source file to
+ -- initialize the allocation of the Obsolescent_Warnings table. Note that
+ -- Initialize must not be called if Tree_Read is used.
+
+ procedure Tree_Read;
+ -- Initializes internal tables from current tree file using the relevant
+ -- Table.Tree_Read routines.
+
+ procedure Tree_Write;
+ -- Writes out internal tables to current tree file using the relevant
+ -- Table.Tree_Write routines.
+
+end Sem_Aux;
with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
-- against a formal access-to-subprogram type so Get_Instance_Of must
-- be called.
- procedure Check_Overriding_Indicator
- (Subp : Entity_Id;
- Overridden_Subp : Entity_Id;
- Is_Primitive : Boolean);
- -- Verify the consistency of an overriding_indicator given for subprogram
- -- declaration, body, renaming, or instantiation. Overridden_Subp is set
- -- if the scope where we are introducing the subprogram contains a
- -- type-conformant subprogram that becomes hidden by the new subprogram.
- -- Is_Primitive indicates whether the subprogram is primitive.
-
procedure Check_Subprogram_Order (N : Node_Id);
-- N is the N_Subprogram_Body node for a subprogram. This routine applies
-- the alpha ordering rule for N if this ordering requirement applicable.
procedure Install_Entity (E : Entity_Id);
-- Make single entity visible. Used for generic formals as well
- procedure Install_Formals (Id : Entity_Id);
- -- On entry to a subprogram body, make the formals visible. Note that
- -- simply placing the subprogram on the scope stack is not sufficient:
- -- the formals must become the current entities for their names.
-
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
New_E : Entity_Id) return Boolean;
-- Flag functions that can be called without parameters, i.e. those that
-- have no parameters, or those for which defaults exist for all parameters
+ procedure Process_PPCs
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Body_Id : Entity_Id);
+ -- Called from Analyze_Body to deal with scanning post conditions for the
+ -- body and assembling and inserting the _postconditions procedure. N is
+ -- the node for the subprogram body and Body_Id/Spec_Id are the entities
+ -- for the body and separate spec (if there is no separate spec, Spec_Id
+ -- is Empty).
+
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
-- setting the proper validity status for this entity, which depends
end if;
-- Subtype_indication case; check that the types are the same, and
- -- statically match if appropriate:
+ -- statically match if appropriate. A null exclusion may be present
+ -- on the return type, on the function specification, on the object
+ -- declaration or on the subtype itself.
elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then
+ if Is_Access_Type (R_Type)
+ and then
+ (Can_Never_Be_Null (R_Type)
+ or else Null_Exclusion_Present (Parent (Scope_Id))) /=
+ Can_Never_Be_Null (R_Stm_Type)
+ then
+ Error_Msg_N
+ ("subtype must statically match function result subtype",
+ Subtype_Ind);
+ end if;
+
if Is_Constrained (R_Type) then
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
Error_Msg_N
end;
end if;
- -- Case of Expr present (Etype check defends against previous errors)
+ -- Case of Expr present
if Present (Expr)
+
+ -- Defend against previous errors
+
+ and then Nkind (Expr) /= N_Empty
and then Present (Etype (Expr))
then
-- Apply constraint check. Note that this is done before the implicit
Analyze_And_Resolve (Expr, R_Type);
end if;
+ -- If the result type is class-wide, then check that the return
+ -- expression's type is not declared at a deeper level than the
+ -- function (RM05-6.5(5.6/2)).
+
+ if Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (R_Type)
+ then
+ if Type_Access_Level (Etype (Expr)) >
+ Subprogram_Access_Level (Scope_Id)
+ then
+ Error_Msg_N
+ ("level of return expression type is deeper than " &
+ "class-wide function!", Expr);
+ end if;
+ end if;
+
if (Is_Class_Wide_Type (Etype (Expr))
or else Is_Dynamically_Tagged (Expr))
and then not Is_Class_Wide_Type (R_Type)
Body_Id : Entity_Id := Defining_Entity (Body_Spec);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Body_Deleted : constant Boolean := False;
-
- HSS : Node_Id;
- Spec_Id : Entity_Id;
- Spec_Decl : Node_Id := Empty;
- Last_Formal : Entity_Id := Empty;
Conformant : Boolean;
+ HSS : Node_Id;
Missing_Ret : Boolean;
P_Ent : Entity_Id;
+ Prot_Typ : Entity_Id := Empty;
+ Spec_Id : Entity_Id;
+ Spec_Decl : Node_Id := Empty;
+
+ Last_Real_Spec_Entity : Entity_Id := Empty;
+ -- When we analyze a separate spec, the entity chain ends up containing
+ -- the formals, as well as any itypes generated during analysis of the
+ -- default expressions for parameters, or the arguments of associated
+ -- precondition/postcondition pragmas (which are analyzed in the context
+ -- of the spec since they have visibility on formals).
+ --
+ -- These entities belong with the spec and not the body. However we do
+ -- the analysis of the body in the context of the spec (again to obtain
+ -- visibility to the formals), and all the entities generated during
+ -- this analysis end up also chained to the entity chain of the spec.
+ -- But they really belong to the body, and there is circuitry to move
+ -- them from the spec to the body.
+ --
+ -- However, when we do this move, we don't want to move the real spec
+ -- entities (first para above) to the body. The Last_Real_Spec_Entity
+ -- variable points to the last real spec entity, so we only move those
+ -- chained beyond that point. It is initialized to Empty to deal with
+ -- the case where there is no separate spec.
procedure Check_Anonymous_Return;
-- (Ada 2005): if a function returns an access type that denotes a task,
-- unconditionally, otherwise only if Front_End_Inlining is requested.
-- If the body acts as a spec, and inlining is required, we create a
-- subprogram declaration for it, in order to attach the body to inline.
-
- procedure Copy_Parameter_List (Plist : List_Id);
- -- Utility to create a parameter profile for a new subprogram spec,
- -- when the subprogram has a body that acts as spec. This is done for
- -- some cases of inlining, and for private protected ops.
+ -- If pragma does not appear after the body, check whether there is
+ -- an inline pragma before any local declarations.
procedure Set_Trivial_Subprogram (N : Node_Id);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the
Prag : Node_Id;
Plist : List_Id;
+ function Is_Inline_Pragma (N : Node_Id) return Boolean;
+ -- Simple predicate, used twice.
+
+ -----------------------
+ -- Is_Inline_Pragma --
+ -----------------------
+
+ function Is_Inline_Pragma (N : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (N) = N_Pragma
+ and then
+ (Pragma_Name (N) = Name_Inline_Always
+ or else
+ (Front_End_Inlining
+ and then Pragma_Name (N) = Name_Inline))
+ and then
+ Chars
+ (Expression (First (Pragma_Argument_Associations (N))))
+ = Chars (Body_Id);
+ end Is_Inline_Pragma;
+
+ -- Start of processing for Check_Inline_Pragma
+
begin
if not Expander_Active then
return;
if Is_List_Member (N)
and then Present (Next (N))
- and then Nkind (Next (N)) = N_Pragma
+ and then Is_Inline_Pragma (Next (N))
then
Prag := Next (N);
- if Nkind (Prag) = N_Pragma
- and then
- (Pragma_Name (Prag) = Name_Inline_Always
- or else
- (Front_End_Inlining
- and then Pragma_Name (Prag) = Name_Inline))
- and then
- Chars
- (Expression (First (Pragma_Argument_Associations (Prag))))
- = Chars (Body_Id)
- then
- Prag := Next (N);
- else
- Prag := Empty;
- end if;
+ elsif Nkind (N) /= N_Subprogram_Body_Stub
+ and then Present (Declarations (N))
+ and then Is_Inline_Pragma (First (Declarations (N)))
+ then
+ Prag := First (Declarations (N));
+
else
Prag := Empty;
end if;
Set_Defining_Unit_Name (Specification (Decl), Subp);
if Present (First_Formal (Body_Id)) then
- Plist := New_List;
- Copy_Parameter_List (Plist);
+ Plist := Copy_Parameter_List (Body_Id);
Set_Parameter_Specifications
(Specification (Decl), Plist);
end if;
if Pragma_Name (Prag) = Name_Inline_Always then
Set_Is_Inlined (Subp);
- Set_Next_Rep_Item (Prag, First_Rep_Item (Subp));
- Set_First_Rep_Item (Subp, Prag);
+ Set_Has_Pragma_Inline_Always (Subp);
end if;
Spec := Subp;
end if;
end Check_Inline_Pragma;
- -------------------------
- -- Copy_Parameter_List --
- -------------------------
-
- procedure Copy_Parameter_List (Plist : List_Id) is
- Formal : Entity_Id;
-
- begin
- Formal := First_Formal (Body_Id);
-
- while Present (Formal) loop
- Append
- (Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Formal),
- Chars => Chars (Formal)),
- In_Present => In_Present (Parent (Formal)),
- Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Reference_To (Etype (Formal), Loc),
- Expression =>
- New_Copy_Tree (Expression (Parent (Formal)))),
- Plist);
-
- Next_Formal (Formal);
- end loop;
- end Copy_Parameter_List;
-
----------------------------
-- Set_Trivial_Subprogram --
----------------------------
procedure Verify_Overriding_Indicator is
begin
- if Must_Override (Body_Spec)
- and then not Is_Overriding_Operation (Spec_Id)
- then
- Error_Msg_NE
- ("subprogram& is not overriding", Body_Spec, Spec_Id);
+ if Must_Override (Body_Spec) then
+ if Nkind (Spec_Id) = N_Defining_Operator_Symbol
+ and then Operator_Matches_Spec (Spec_Id, Spec_Id)
+ then
+ null;
+
+ elsif not Is_Overriding_Operation (Spec_Id) then
+ Error_Msg_NE
+ ("subprogram& is not overriding", Body_Spec, Spec_Id);
+ end if;
elsif Must_Not_Override (Body_Spec) then
if Is_Overriding_Operation (Spec_Id) then
("subprogram& overrides inherited operation",
Body_Spec, Spec_Id);
+ elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
+ and then Operator_Matches_Spec (Spec_Id, Spec_Id)
+ then
+ Error_Msg_NE
+ ("subprogram & overrides predefined operator ",
+ Body_Spec, Spec_Id);
+
-- If this is not a primitive operation the overriding indicator
-- is altogether illegal.
if Present (Formal)
or else Expander_Active
then
- Plist := New_List;
-
+ Plist := Copy_Parameter_List (Body_Id);
else
Plist := No_List;
end if;
- Copy_Parameter_List (Plist);
-
if Nkind (Body_Spec) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
if Is_Abstract_Subprogram (Spec_Id) then
Error_Msg_N ("an abstract subprogram cannot have a body", N);
return;
+
else
Set_Convention (Body_Id, Convention (Spec_Id));
Set_Has_Completion (Spec_Id);
if Is_Protected_Type (Scope (Spec_Id)) then
- Set_Privals_Chain (Spec_Id, New_Elmt_List);
+ Prot_Typ := Scope (Spec_Id);
end if;
-- If this is a body generated for a renaming, do not check for
Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id))))
and then
Present
- (Corresponding_Concurrent_Type
- (Etype (First_Entity (Spec_Id))))
+ (Corresponding_Concurrent_Type
+ (Etype (First_Entity (Spec_Id))))
then
declare
Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
end;
end if;
- -- Make the formals visible, and place subprogram on scope stack
+ -- Make the formals visible, and place subprogram on scope stack.
+ -- This is also the point at which we set Last_Real_Spec_Entity
+ -- to mark the entities which will not be moved to the body.
Install_Formals (Spec_Id);
- Last_Formal := Last_Entity (Spec_Id);
+ Last_Real_Spec_Entity := Last_Entity (Spec_Id);
Push_Scope (Spec_Id);
-- Make sure that the subprogram is immediately visible. For
-- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
-- if its specification we have to install the private withed units.
+ -- This holds for child units as well.
if Is_Compilation_Unit (Body_Id)
- and then Scope (Body_Id) = Standard_Standard
+ or else Nkind (Parent (N)) = N_Compilation_Unit
then
Install_Private_With_Clauses (Body_Id);
end if;
begin
while Present (Prot_Ext_Formal) loop
pragma Assert (Present (Impl_Ext_Formal));
-
Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal);
-
Next_Formal_With_Extras (Prot_Ext_Formal);
Next_Formal_With_Extras (Impl_Ext_Formal);
end loop;
HSS := Handled_Statement_Sequence (N);
Set_Actual_Subtypes (N, Current_Scope);
+
+ -- Deal with preconditions and postconditions
+
+ Process_PPCs (N, Spec_Id, Body_Id);
+
+ -- Add a declaration for the Protection objcect, renaming declarations
+ -- for discriminals and privals and finally a declaration for the entry
+ -- family index (if applicable). This form of early expansion is done
+ -- when the Expander is active because Install_Private_Data_Declarations
+ -- references entities which were created during regular expansion.
+
+ if Expander_Active
+ and then Comes_From_Source (N)
+ and then Present (Prot_Typ)
+ and then Present (Spec_Id)
+ and then not Is_Eliminated (Spec_Id)
+ then
+ Install_Private_Data_Declarations
+ (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N));
+ end if;
+
+ -- Analyze the declarations (this call will analyze the precondition
+ -- Check pragmas we prepended to the list, as well as the declaration
+ -- of the _Postconditions procedure).
+
Analyze_Declarations (Declarations (N));
+
+ -- Check completion, and analyze the statements
+
Check_Completion;
Analyze (HSS);
+
+ -- Deal with end of scope processing for the body
+
Process_End_Label (HSS, 't', Current_Scope);
End_Scope;
Check_Subprogram_Order (N);
(Unit_Declaration_Node (Spec_Id), Spec_Id);
end if;
- if Present (Last_Formal) then
- Set_Next_Entity
- (Last_Entity (Body_Id), Next_Entity (Last_Formal));
- Set_Next_Entity (Last_Formal, Empty);
+ -- Here is where we move entities from the spec to the body
+
+ -- Case where there are entities that stay with the spec
+
+ if Present (Last_Real_Spec_Entity) then
+
+ -- No body entities (happens when the only real spec entities
+ -- come from precondition and postcondition pragmas)
+
+ if No (Last_Entity (Body_Id)) then
+ Set_First_Entity
+ (Body_Id, Next_Entity (Last_Real_Spec_Entity));
+
+ -- Body entities present (formals), so chain stuff past them
+
+ else
+ Set_Next_Entity
+ (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
+ end if;
+
+ Set_Next_Entity (Last_Real_Spec_Entity, Empty);
Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
- Set_Last_Entity (Spec_Id, Last_Formal);
+ Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity);
+
+ -- Case where there are no spec entities, in this case there can
+ -- be no body entities either, so just move everything.
else
+ pragma Assert (No (Last_Entity (Body_Id)));
Set_First_Entity (Body_Id, First_Entity (Spec_Id));
Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
Set_First_Entity (Spec_Id, Empty);
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
Designator : constant Entity_Id := Defining_Entity (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
Formal : Entity_Id;
Formal_Typ : Entity_Id;
- Formals : constant List_Id := Parameter_Specifications (N);
-- Start of processing for Analyze_Subprogram_Specification
if Is_Abstract_Type (Etype (Designator))
and then not Is_Interface (Etype (Designator))
- and then Nkind (Parent (N))
- /= N_Abstract_Subprogram_Declaration
- and then (Nkind (Parent (N)))
- /= N_Formal_Abstract_Subprogram_Declaration
- and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- or else not Is_Entity_Name (Name (Parent (N)))
- or else not Is_Abstract_Subprogram
+ and then Nkind (Parent (N)) /=
+ N_Abstract_Subprogram_Declaration
+ and then
+ (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
+ and then
+ (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
+ or else not Is_Entity_Name (Name (Parent (N)))
+ or else not Is_Abstract_Subprogram
(Entity (Name (Parent (N)))))
then
Error_Msg_N
if NewD then
Push_Scope (New_Id);
- Analyze_Per_Use_Expression
+ Preanalyze_Spec_Expression
(Default_Value (New_Formal), Etype (New_Formal));
End_Scope;
end if;
-- expanded, so expand now to check conformance.
if NewD then
- Analyze_Per_Use_Expression
+ Preanalyze_Spec_Expression
(Expression (New_Discr), New_Discr_Type);
end if;
Error_Msg_NE
("subprogram & overrides inherited operation #", Spec, Subp);
end if;
+
+ elsif Is_Subprogram (Subp) then
+ Set_Is_Overriding_Operation (Subp);
end if;
-- If Subp is an operator, it may override a predefined operation.
-- signature of Subp matches that of a predefined operator. Note that
-- first argument provides the name of the operator, and the second
-- argument the signature that may match that of a standard operation.
+ -- If the indicator is overriding, then the operator must match a
+ -- predefined signature, because we know already that there is no
+ -- explicit overridden operation.
- elsif Nkind (Subp) = N_Defining_Operator_Symbol
- and then Must_Not_Override (Spec)
- then
- if Operator_Matches_Spec (Subp, Subp) then
- Error_Msg_NE
- ("subprogram & overrides predefined operator ",
- Spec, Subp);
- end if;
+ elsif Nkind (Subp) = N_Defining_Operator_Symbol then
- elsif Must_Override (Spec) then
- if Ekind (Subp) = E_Entry then
- Error_Msg_NE ("entry & is not overriding", Spec, Subp);
+ if Must_Not_Override (Spec) then
+ if not Is_Primitive then
+ Error_Msg_N
+ ("overriding indicator only allowed "
+ & "if subprogram is primitive", Subp);
- elsif Nkind (Subp) = N_Defining_Operator_Symbol then
- if not Operator_Matches_Spec (Subp, Subp) then
+ elsif Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
- ("subprogram & is not overriding", Spec, Subp);
+ ("subprogram & overrides predefined operator ", Spec, Subp);
end if;
+ elsif Is_Overriding_Operation (Subp) then
+ null;
+
+ elsif Must_Override (Spec) then
+ if not Operator_Matches_Spec (Subp, Subp) then
+ Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
+
+ else
+ Set_Is_Overriding_Operation (Subp);
+ end if;
+ end if;
+
+ elsif Must_Override (Spec) then
+ if Ekind (Subp) = E_Entry then
+ Error_Msg_NE ("entry & is not overriding", Spec, Subp);
else
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
end if;
Error_Msg_N
("overriding indicator only allowed if subprogram is primitive",
Subp);
-
return;
end if;
end Check_Overriding_Indicator;
begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt);
Set_Etype (Formal_Type, Formal_Type);
- Init_Size_Align (Formal_Type);
Set_Depends_On_Private
(Formal_Type, Has_Private_Component (Formal_Type));
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
Default : Node_Id;
Ptype : Entity_Id;
- -- The following are used for setting Is_Only_Out_
Num_Out_Params : Nat := 0;
First_Out_Param : Entity_Id := Empty;
+ -- Used for setting Is_Only_Out_Parameter
function Is_Class_Wide_Default (D : Node_Id) return Boolean;
-- Check whether the default has a class-wide type. After analysis the
-- Do the special preanalysis of the expression (see section on
-- "Handling of Default Expressions" in the spec of package Sem).
- Analyze_Per_Use_Expression (Default, Formal_Type);
+ Preanalyze_Spec_Expression (Default, Formal_Type);
-- An access to constant cannot be the default for
-- an access parameter that is an access to variable.
end if;
end Process_Formals;
+ ------------------
+ -- Process_PPCs --
+ ------------------
+
+ procedure Process_PPCs
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Body_Id : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Prag : Node_Id;
+ Plist : List_Id := No_List;
+ Subp : Entity_Id;
+ Parms : List_Id;
+
+ function Grab_PPC (Nam : Name_Id) return Node_Id;
+ -- Prag contains an analyzed precondition or postcondition pragma.
+ -- This function copies the pragma, changes it to the corresponding
+ -- Check pragma and returns the Check pragma as the result. The
+ -- argument Nam is either Name_Precondition or Name_Postcondition.
+
+ --------------
+ -- Grab_PPC --
+ --------------
+
+ function Grab_PPC (Nam : Name_Id) return Node_Id is
+ CP : constant Node_Id := New_Copy_Tree (Prag);
+
+ begin
+ -- Set Analyzed to false, since we want to reanalyze the check
+ -- procedure. Note that it is only at the outer level that we
+ -- do this fiddling, for the spec cases, the already preanalyzed
+ -- parameters are not affected.
+
+ Set_Analyzed (CP, False);
+
+ -- Change pragma into corresponding pragma Check
+
+ Prepend_To (Pragma_Argument_Associations (CP),
+ Make_Pragma_Argument_Association (Sloc (Prag),
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Nam)));
+ Set_Pragma_Identifier (CP,
+ Make_Identifier (Sloc (Prag),
+ Chars => Name_Check));
+
+ return CP;
+ end Grab_PPC;
+
+ -- Start of processing for Process_PPCs
+
+ begin
+ -- Grab preconditions from spec
+
+ if Present (Spec_Id) then
+
+ -- Loop through PPC pragmas from spec. Note that preconditions from
+ -- the body will be analyzed and converted when we scan the body
+ -- declarations below.
+
+ Prag := Spec_PPC_List (Spec_Id);
+ while Present (Prag) loop
+ if Pragma_Name (Prag) = Name_Precondition
+ and then PPC_Enabled (Prag)
+ then
+ -- Add pragma Check at the start of the declarations of N.
+ -- Note that this processing reverses the order of the list,
+ -- which is what we want since new entries were chained to
+ -- the head of the list.
+
+ Prepend (Grab_PPC (Name_Precondition), Declarations (N));
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ -- Build postconditions procedure if needed and prepend the following
+ -- declaration to the start of the declarations for the subprogram.
+
+ -- procedure _postconditions [(_Result : resulttype)] is
+ -- begin
+ -- pragma Check (Postcondition, condition [,message]);
+ -- pragma Check (Postcondition, condition [,message]);
+ -- ...
+ -- end;
+
+ -- First we deal with the postconditions in the body
+
+ if Is_Non_Empty_List (Declarations (N)) then
+
+ -- Loop through declarations
+
+ Prag := First (Declarations (N));
+ while Present (Prag) loop
+ if Nkind (Prag) = N_Pragma then
+
+ -- If pragma, capture if enabled postcondition, else ignore
+
+ if Pragma_Name (Prag) = Name_Postcondition
+ and then Check_Enabled (Name_Postcondition)
+ then
+ if Plist = No_List then
+ Plist := Empty_List;
+ end if;
+
+ Analyze (Prag);
+ Append (Grab_PPC (Name_Postcondition), Plist);
+ end if;
+
+ Next (Prag);
+
+ -- Not a pragma, if comes from source, then end scan
+
+ elsif Comes_From_Source (Prag) then
+ exit;
+
+ -- Skip stuff not coming from source
+
+ else
+ Next (Prag);
+ end if;
+ end loop;
+ end if;
+
+ -- Now deal with any postconditions from the spec
+
+ if Present (Spec_Id) then
+
+ -- Loop through PPC pragmas from spec
+
+ Prag := Spec_PPC_List (Spec_Id);
+ while Present (Prag) loop
+ if Pragma_Name (Prag) = Name_Postcondition
+ and then PPC_Enabled (Prag)
+ then
+ if Plist = No_List then
+ Plist := Empty_List;
+ end if;
+
+ Append (Grab_PPC (Name_Postcondition), Plist);
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ -- If we had any postconditions, build the procedure
+
+ if Present (Plist) then
+ Subp := Defining_Entity (N);
+
+ if Etype (Subp) /= Standard_Void_Type then
+ Parms := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_uResult),
+ Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
+ else
+ Parms := No_List;
+ end if;
+
+ Prepend_To (Declarations (N),
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_uPostconditions),
+ Parameter_Specifications => Parms),
+
+ Declarations => Empty_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Plist)));
+
+ if Present (Spec_Id) then
+ Set_Has_Postconditions (Spec_Id);
+ else
+ Set_Has_Postconditions (Body_Id);
+ end if;
+ end if;
+ end Process_PPCs;
+
----------------------------
-- Reference_Body_Formals --
----------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- formal access-to-subprogram type, indicating that mapping of types
-- is needed.
+ procedure Check_Overriding_Indicator
+ (Subp : Entity_Id;
+ Overridden_Subp : Entity_Id;
+ Is_Primitive : Boolean);
+ -- Verify the consistency of an overriding_indicator given for subprogram
+ -- declaration, body, renaming, or instantiation. Overridden_Subp is set
+ -- if the scope where we are introducing the subprogram contains a
+ -- type-conformant subprogram that becomes hidden by the new subprogram.
+ -- Is_Primitive indicates whether the subprogram is primitive.
+
procedure Check_Subtype_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
function Fully_Conformant_Expressions
(Given_E1 : Node_Id;
- Given_E2 : Node_Id)
- return Boolean;
+ Given_E2 : Node_Id) return Boolean;
-- Determines if two (non-empty) expressions are fully conformant
-- as defined by (RM 6.3.1(18-21))
function Fully_Conformant_Discrete_Subtypes
(Given_S1 : Node_Id;
- Given_S2 : Node_Id)
- return Boolean;
+ Given_S2 : Node_Id) return Boolean;
-- Determines if two subtype definitions are fully conformant. Used
-- for entry family conformance checks (RM 6.3.1 (24)).
+ procedure Install_Formals (Id : Entity_Id);
+ -- On entry to a subprogram body, make the formals visible. Note that
+ -- simply placing the subprogram on the scope stack is not sufficient:
+ -- the formals must become the current entities for their names. This
+ -- procedure is also used to get visibility to the formals when analyzing
+ -- preconditions and postconditions appearing in the spec.
+
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are mode conformant (RM 6.3.1(15))
and then Nkind (Nam) in N_Has_Entity
then
declare
- Error_Node : Node_Id;
Nam_Decl : Node_Id;
Nam_Ent : Entity_Id;
- Subtyp_Decl : Node_Id;
begin
if Nkind (Nam) = N_Attribute_Reference then
end if;
Nam_Decl := Parent (Nam_Ent);
- Subtyp_Decl := Parent (Etype (Nam_Ent));
if Has_Null_Exclusion (N)
and then not Has_Null_Exclusion (Nam_Decl)
if Is_Formal_Object (Nam_Ent)
and then In_Generic_Scope (Id)
then
- if Present (Subtype_Mark (Nam_Decl)) then
- Error_Node := Subtype_Mark (Nam_Decl);
- else
- pragma Assert
- (Ada_Version >= Ada_05
- and then Present (Access_Definition (Nam_Decl)));
-
- Error_Node := Access_Definition (Nam_Decl);
- end if;
-
- Error_Msg_N
- ("`NOT NULL` required in formal object declaration",
- Error_Node);
- Error_Msg_Sloc := Sloc (N);
Error_Msg_N
- ("\because of renaming # (RM 8.5.4(4))", Error_Node);
+ ("renamed formal does not exclude `NULL` "
+ & "(RM 8.5.1(4.6/2))", N);
-- Ada 2005 (AI-423): Otherwise, the subtype of the object name
-- shall exclude null.
- elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration
- and then not Has_Null_Exclusion (Subtyp_Decl)
- then
+ elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then
Error_Msg_N
- ("`NOT NULL` required for subtype & (RM 8.5.1(4.6/2))",
- Defining_Identifier (Subtyp_Decl));
+ ("renamed object does not exclude `NULL` "
+ & "(RM 8.5.1(4.6/2))", N);
end if;
end if;
end;
then
null;
+ -- Allow internally generated x'Reference expression
+
+ elsif Nkind (Nam) = N_Reference then
+ null;
+
else
Error_Msg_N ("expect object name in renaming", Nam);
end if;
elsif not Redundant_Use (Id) then
Set_In_Use (T, False);
Set_In_Use (Base_Type (T), False);
+ Set_Current_Use_Clause (T, Empty);
+ Set_Current_Use_Clause (Base_Type (T), Empty);
Op_List := Collect_Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
declare
Case_Stm : constant Node_Id := Parent (Parent (N));
Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
- Case_Rtp : constant Entity_Id := Root_Type (Case_Typ);
Lit : Node_Id;
begin
if Is_Enumeration_Type (Case_Typ)
- and then Case_Rtp /= Standard_Character
- and then Case_Rtp /= Standard_Wide_Character
- and then Case_Rtp /= Standard_Wide_Wide_Character
+ and then not Is_Standard_Character_Type (Case_Typ)
then
Lit := First_Literal (Case_Typ);
Get_Name_String (Chars (Lit));
if Is_Object (E) and then Present (Renamed_Object (E)) then
Generate_Reference (E, N);
+ -- If the renamed entity is a private protected component,
+ -- reference the original component as well. This needs to be
+ -- done because the private renamings are installed before any
+ -- analysis has occured. Reference to a private component will
+ -- resolve to the renaming and the original component will be
+ -- left unreferenced, hence the following.
+
+ if Is_Prival (E) then
+ Generate_Reference (Prival_Link (E), N);
+ end if;
+
-- One odd case is that we do not want to set the Referenced flag
-- if the entity is a label, and the identifier is the label in
-- the source, since this is not a reference from the point of
-- (because implicit derefences cannot be identified prior to
-- full type resolution).
--
- -- ??? The Is_Actual_Parameter routine takes care of one of these
- -- cases but there are others probably
+ -- The Is_Actual_Parameter routine takes care of one of these
+ -- cases but there are others probably ???
else
if not Is_Actual_Parameter then
-- processing a generic spec or body, because the discriminal
-- has not been not generated in this case.
- if not In_Default_Expression
+ -- The replacement is also skipped if we are in special
+ -- spec-expression mode. Why is this skipped in this case ???
+
+ if not In_Spec_Expression
or else Ekind (E) /= E_Discriminant
or else Inside_A_Generic
then
else
Error_Msg_N
("limited withed package can only be used to access "
- & " incomplete types",
+ & "incomplete types",
N);
end if;
end if;
end if;
Id := First_Entity (P);
-
while Present (Id)
and then Id /= Priv_Id
loop
- if Is_Character_Type (Id)
- and then (Root_Type (Id) = Standard_Character
- or else Root_Type (Id) = Standard_Wide_Character
- or else Root_Type (Id) = Standard_Wide_Wide_Character)
+ if Is_Standard_Character_Type (Id)
and then Id = Base_Type (Id)
then
-- We replace the node with the literal itself, resolve as a
Write_Info;
end if;
- Scope_Suppress := SST.Save_Scope_Suppress;
+ Scope_Suppress := SST.Save_Scope_Suppress;
Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top;
+ Check_Policy_List := SST.Save_Check_Policy_List;
if Debug_Flag_W then
Write_Str ("--> exiting scope: ");
SST.Entity := S;
SST.Save_Scope_Suppress := Scope_Suppress;
SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
+ SST.Save_Check_Policy_List := Check_Policy_List;
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table
elsif not Redundant_Use (Id) then
Set_In_Use (T);
+ Set_Current_Use_Clause (T, Parent (Id));
Op_List := Collect_Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
-- The type already has a use clause
if In_Use (T) then
- Error_Msg_NE
- ("& is already use-visible through previous use type clause?",
- Id, Id);
+ if Present (Current_Use_Clause (T)) then
+ declare
+ Clause1 : constant Node_Id := Parent (Id);
+ Clause2 : constant Node_Id := Current_Use_Clause (T);
+ Err_No : Node_Id;
+ Unit1 : Node_Id;
+ Unit2 : Node_Id;
+
+ begin
+ if Nkind (Parent (Clause1)) = N_Compilation_Unit
+ and then Nkind (Parent (Clause2)) = N_Compilation_Unit
+ then
+ -- There is a redundant use type clause in a child unit.
+ -- Determine which of the units is more deeply nested.
+
+ Unit1 := Defining_Entity (Unit (Parent (Clause1)));
+ Unit2 := Defining_Entity (Unit (Parent (Clause2)));
+
+ if Scope (Unit2) = Standard_Standard then
+ Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
+ Err_No := Clause1;
+
+ elsif Scope (Unit1) = Standard_Standard then
+ Error_Msg_Sloc := Sloc (Id);
+ Err_No := Clause2;
+
+ else
+ -- Determine which is the descendant unit
+
+ declare
+ S1, S2 : Entity_Id;
+
+ begin
+ S1 := Scope (Unit1);
+ S2 := Scope (Unit2);
+ while S1 /= Standard_Standard
+ and then S2 /= Standard_Standard
+ loop
+ S1 := Scope (S1);
+ S2 := Scope (S2);
+ end loop;
+
+ if S1 = Standard_Standard then
+ Error_Msg_Sloc := Sloc (Id);
+ Err_No := Clause2;
+ else
+ Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
+ Err_No := Clause1;
+ end if;
+ end;
+ end if;
+
+ Error_Msg_NE
+ ("& is already use-visible through previous "
+ & "use_type_clause #?", Err_No, Id);
+ else
+ Error_Msg_NE
+ ("& is already use-visible through previous use type "
+ & "clause?", Id, Id);
+ end if;
+ end;
+ else
+ Error_Msg_NE
+ ("& is already use-visible through previous use type "
+ & "clause?", Id, Id);
+ end if;
-- The package where T is declared is already used
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dist; use Sem_Dist;
-- (the original one, following the renaming chain) is returned.
-- Otherwise the entity is returned unchanged. Should be in Einfo???
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
+ -- All the routines that check pragma arguments take either a pragma
+ -- argument association (in which case the expression of the argument
+ -- association is checked), or the expression directly. The function
+ -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg
+ -- is a pragma argument association node, then its expression is returned,
+ -- otherwise Arg is returned unchanged.
+
procedure rv;
-- This is a dummy function called by the processing for pragma Reviewable.
-- It is there for assisting front end debugging. By placing a Reviewable
end if;
end Adjust_External_Name_Case;
+ ------------------------------
+ -- Analyze_PPC_In_Decl_Part --
+ ------------------------------
+
+ procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (N));
+ Arg2 : constant Node_Id := Next (Arg1);
+
+ begin
+ -- Install formals and push subprogram spec onto scope stack
+ -- so that we can see the formals from the pragma.
+
+ Install_Formals (S);
+ Push_Scope (S);
+
+ -- Preanalyze the boolean expression, we treat this as a
+ -- spec expression (i.e. similar to a default expression).
+
+ Preanalyze_Spec_Expression
+ (Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ -- If there is a message argument, analyze it the same way
+
+ if Present (Arg2) then
+ Preanalyze_Spec_Expression
+ (Get_Pragma_Arg (Arg2), Standard_String);
+ end if;
+
+ -- Remove the subprogram from the scope stack now that the
+ -- pre-analysis of the precondition/postcondition is done.
+
+ End_Scope;
+ end Analyze_PPC_In_Decl_Part;
+
--------------------
-- Analyze_Pragma --
--------------------
procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
+ procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
-- Check the specified argument Arg to make sure that it is an
-- identifier whose name matches either N1 or N2 (or N3 if present).
-- If not then give error and raise Pragma_Exit.
procedure Check_In_Main_Program;
-- Common checks for pragmas that appear within a main program
- -- (Priority, Main_Storage, Time_Slice).
+ -- (Priority, Main_Storage, Time_Slice, Relative_Deadline).
procedure Check_Interrupt_Or_Attach_Handler;
-- Common processing for first argument of pragma Interrupt_Handler
-- In this version of the procedure, the identifier name is given as
-- a string with lower case letters.
+ procedure Check_Precondition_Postcondition (In_Body : out Boolean);
+ -- Called to process a precondition or postcondition pragma. There are
+ -- three cases:
+ --
+ -- The pragma appears after a subprogram spec
+ --
+ -- If the corresponding check is not enabled, the pragma is analyzed
+ -- but otherwise ignored and control returns with In_Body set False.
+ --
+ -- If the check is enabled, then the first step is to analyze the
+ -- pragma, but this is skipped if the subprogram spec appears within
+ -- a package specification (because this is the case where we delay
+ -- analysis till the end of the spec). Then (whether or not it was
+ -- analyzed), the pragma is chained to the subprogram in question
+ -- (using Spec_PPC_List and Next_Pragma) and control returns to the
+ -- caller with In_Body set False.
+ --
+ -- The pragma appears at the start of subprogram body declarations
+ --
+ -- In this case an immediate return to the caller is made with
+ -- In_Body set True, and the pragma is NOT analyzed.
+ --
+ -- In all other cases, an error message for bad placement is given
+
procedure Check_Static_Constraint (Constr : Node_Id);
-- Constr is a constraint from an N_Subtype_Indication node from a
-- component constraint in an Unchecked_Union type. This routine checks
-- optional identifiers when it returns). An entry in Args is Empty
-- on return if the corresponding argument is not present.
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
- -- All the routines that check pragma arguments take either a pragma
- -- argument association (in which case the expression of the argument
- -- association is checked), or the expression directly. The function
- -- Get_Pragma_Arg is a utility used to deal with these two cases. If
- -- Arg is a pragma argument association node, then its expression is
- -- returned, otherwise Arg is returned unchanged.
-
procedure GNAT_Pragma;
-- Called for all GNAT defined pragmas to check the relevant restriction
-- (No_Implementation_Pragmas).
end if;
end Check_Arg_Is_One_Of;
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if Chars (Argx) /= N1
+ and then Chars (Argx) /= N2
+ and then Chars (Argx) /= N3
+ and then Chars (Argx) /= N4
+ then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
---------------------------------
-- Check_Arg_Is_Queuing_Policy --
---------------------------------
Check_Optional_Identifier (Arg, Name_Find);
end Check_Optional_Identifier;
+ --------------------------------------
+ -- Check_Precondition_Postcondition --
+ --------------------------------------
+
+ procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
+ P : Node_Id;
+ S : Entity_Id;
+ PO : Node_Id;
+
+ begin
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ end if;
+
+ -- Record whether pragma is enabled
+
+ Set_PPC_Enabled (N, Check_Enabled (Pname));
+
+ -- Search prior declarations
+
+ P := N;
+ while Present (Prev (P)) loop
+ P := Prev (P);
+ PO := Original_Node (P);
+
+ -- Skip past prior pragma
+
+ if Nkind (PO) = N_Pragma then
+ null;
+
+ -- Skip stuff not coming from source
+
+ elsif not Comes_From_Source (PO) then
+ null;
+
+ -- Here if we hit a subprogram declaration
+
+ elsif Nkind (PO) = N_Subprogram_Declaration then
+ S := Defining_Unit_Name (Specification (PO));
+
+ -- Analyze the pragma unless it appears within a package spec,
+ -- which is the case where we delay the analysis of the PPC
+ -- until the end of the package declarations (for details,
+ -- see Analyze_Package_Specification.Analyze_PPCs).
+
+ if Ekind (Scope (S)) /= E_Package
+ and then
+ Ekind (Scope (S)) /= E_Generic_Package
+ then
+ Analyze_PPC_In_Decl_Part (N, S);
+ end if;
+
+ -- Chain spec PPC pragma to list for subprogram
+
+ Set_Next_Pragma (N, Spec_PPC_List (S));
+ Set_Spec_PPC_List (S, N);
+
+ -- Return indicating spec case
+
+ In_Body := False;
+ return;
+
+ -- If we encounter any other declaration moving back, misplaced
+
+ else
+ Pragma_Misplaced;
+ end if;
+ end loop;
+
+ -- If we fall through loop, pragma is at start of list, so see if
+ -- it is at the start of declarations of a subprogram body.
+
+ if Nkind (Parent (N)) = N_Subprogram_Body
+ and then List_Containing (N) = Declarations (Parent (N))
+ then
+ In_Body := True;
+ return;
+
+ -- If not, it was misplaced
+
+ else
+ Pragma_Misplaced;
+ end if;
+ end Check_Precondition_Postcondition;
+
-----------------------------
-- Check_Static_Constraint --
-----------------------------
procedure Check_Static_Constraint (Constr : Node_Id) is
+ procedure Require_Static (E : Node_Id);
+ -- Require given expression to be static expression
+
--------------------
-- Require_Static --
--------------------
- procedure Require_Static (E : Node_Id);
- -- Require given expression to be static expression
-
procedure Require_Static (E : Node_Id) is
begin
if not Is_OK_Static_Expression (E) then
end loop;
end Gather_Associations;
- --------------------
- -- Get_Pragma_Arg --
- --------------------
-
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
- begin
- if Nkind (Arg) = N_Pragma_Argument_Association then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end Get_Pragma_Arg;
-
-----------------
-- GNAT_Pragma --
-----------------
Utyp : Entity_Id;
procedure Set_Atomic (E : Entity_Id);
- -- Set given type as atomic, and if no explicit alignment was
- -- given, set alignment to unknown, since back end knows what
- -- the alignment requirements are for atomic arrays. Note that
- -- this step is necessary for derived types.
+ -- Set given type as atomic, and if no explicit alignment was given,
+ -- set alignment to unknown, since back end knows what the alignment
+ -- requirements are for atomic arrays. Note: this step is necessary
+ -- for derived types.
----------------
-- Set_Atomic --
Set_Atomic (Base_Type (E));
end if;
- -- Attribute belongs on the base type. If the
- -- view of the type is currently private, it also
- -- belongs on the underlying type.
+ -- Attribute belongs on the base type. If the view of the type is
+ -- currently private, it also belongs on the underlying type.
Set_Is_Volatile (Base_Type (E));
Set_Is_Volatile (Underlying_Type (E));
if Prag_Id /= Pragma_Volatile then
Set_Is_Atomic (E);
- -- If the object declaration has an explicit
- -- initialization, a temporary may have to be
- -- created to hold the expression, to insure
- -- that access to the object remain atomic.
+ -- If the object declaration has an explicit initialization, a
+ -- temporary may have to be created to hold the expression, to
+ -- ensure that access to the object remain atomic.
if Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
E1 := Homonym (E1);
exit when No (E1) or else Scope (E1) /= Current_Scope;
+ -- Do not set the pragma on inherited operations or on
+ -- formal subprograms.
+
if Comes_From_Source (E1)
and then Comp_Unit = Get_Source_Unit (E1)
+ and then not Is_Formal_Subprogram (E1)
and then Nkind (Original_Node (Parent (E1))) /=
N_Full_Type_Declaration
then
"\no initialization allowed for & declared#", Arg1);
else
Set_Imported (Def_Id);
- Note_Possible_Modification (Arg_Internal);
+ Note_Possible_Modification (Arg_Internal, Sure => False);
end if;
end if;
end Process_Extended_Import_Export_Object_Pragma;
begin
Process_Convention (C, Def_Id);
Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Expression (Arg2));
+ Note_Possible_Modification (Expression (Arg2), Sure => False);
if Ekind (Def_Id) = E_Variable
or else
return;
-- Here we have a candidate for inlining, but we must exclude
- -- derived operations. Otherwise we will end up trying to
- -- inline a phantom declaration, and the result would be to
- -- drag in a body which has no direct inlining associated with
- -- it. That would not only be inefficient but would also result
- -- in the backend doing cross-unit inlining in cases where it
- -- was definitely inappropriate to do so.
-
- -- However, a simple Comes_From_Source test is insufficient,
- -- since we do want to allow inlining of generic instances,
- -- which also do not come from source. Predefined operators do
- -- not come from source but are not inlineable either.
+ -- derived operations. Otherwise we would end up trying to inline
+ -- a phantom declaration, and the result would be to drag in a
+ -- body which has no direct inlining associated with it. That
+ -- would not only be inefficient but would also result in the
+ -- backend doing cross-unit inlining in cases where it was
+ -- definitely inappropriate to do so.
+
+ -- However, a simple Comes_From_Source test is insufficient, since
+ -- we do want to allow inlining of generic instances which also do
+ -- not come from source. We also need to recognize specs
+ -- generated by the front-end for bodies that carry the pragma.
+ -- Finally, predefined operators do not come from source but are
+ -- not inlineable either.
+
+ elsif Is_Generic_Instance (Subp)
+ or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
+ then
+ null;
elsif not Comes_From_Source (Subp)
- and then not Is_Generic_Instance (Subp)
and then Scope (Subp) /= Standard_Standard
then
Applies := True;
return;
+ end if;
-- The referenced entity must either be the enclosing entity,
-- or an entity declared within the current open scope.
- elsif Present (Scope (Subp))
+ if Present (Scope (Subp))
and then Scope (Subp) /= Current_Scope
and then Subp /= Current_Scope
then
(Process_Restriction_Synonyms (Expr));
if R_Id not in All_Boolean_Restrictions then
- Error_Pragma_Arg
- ("invalid restriction identifier", Arg);
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
+
+ -- Check for possible misspelling
+
+ for J in Restriction_Id loop
+ declare
+ Rnm : constant String := Restriction_Id'Image (J);
+
+ begin
+ Name_Buffer (1 .. Rnm'Length) := Rnm;
+ Name_Len := Rnm'Length;
+ Set_Casing (All_Lower_Case);
+
+ if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
+ Set_Casing
+ (Identifier_Casing (Current_Source_File));
+ Error_Msg_String (1 .. Rnm'Length) :=
+ Name_Buffer (1 .. Name_Len);
+ Error_Msg_Strlen := Rnm'Length;
+ Error_Msg_N
+ ("\possible misspelling of ""~""",
+ Get_Pragma_Arg (Arg));
+ exit;
+ end if;
+ end;
+ end loop;
+
+ raise Pragma_Exit;
end if;
if Implementation_Restriction (R_Id) then
- Check_Restriction
- (No_Implementation_Restrictions, Arg);
+ Check_Restriction (No_Implementation_Restrictions, Arg);
end if;
-- If this is a warning, then set the warning unless we already
when Pragma_Assert => Assert : declare
Expr : Node_Id;
- Eloc : Source_Ptr;
+ Newa : List_Id;
begin
Ada_2005_Pragma;
Check_Arg_Order ((Name_Check, Name_Message));
Check_Optional_Identifier (Arg1, Name_Check);
- if Arg_Count > 1 then
- Check_Optional_Identifier (Arg2, Name_Message);
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
- end if;
-
- -- If expansion is active and assertions are inactive, then
- -- we rewrite the Assertion as:
+ -- We treat pragma Assert as equivalent to:
- -- if False and then condition then
- -- null;
- -- end if;
+ -- pragma Check (Assertion, condition [, msg]);
- -- The reason we do this rewriting during semantic analysis rather
- -- than as part of normal expansion is that we cannot analyze and
- -- expand the code for the boolean expression directly, or it may
- -- cause insertion of actions that would escape the attempt to
- -- suppress the assertion code.
+ -- So rewrite pragma in this manner, and analyze the result
- -- Note that the Sloc for the if statement corresponds to the
- -- argument condition, not the pragma itself. The reason for this
- -- is that we may generate a warning if the condition is False at
- -- compile time, and we do not want to delete this warning when we
- -- delete the if statement.
+ Expr := Get_Pragma_Arg (Arg1);
+ Newa := New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Name_Assertion)),
- Expr := Expression (Arg1);
- Eloc := Sloc (Expr);
+ Make_Pragma_Argument_Association (Sloc (Expr),
+ Expression => Expr));
- if Expander_Active and not Assertions_Enabled then
- Rewrite (N,
- Make_If_Statement (Eloc,
- Condition =>
- Make_And_Then (Eloc,
- Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
- Right_Opnd => Expr),
- Then_Statements => New_List (
- Make_Null_Statement (Eloc))));
-
- Analyze (N);
-
- -- Otherwise (if assertions are enabled, or if we are not
- -- operating with expansion active), then we just analyze
- -- and resolve the expression.
-
- else
- Analyze_And_Resolve (Expr, Any_Boolean);
+ if Arg_Count > 1 then
+ Check_Optional_Identifier (Arg2, Name_Message);
+ Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
+ Append_To (Newa, Relocate_Node (Arg2));
end if;
- -- If assertion is of the form (X'First = literal), where X is
- -- formal parameter, then set Low_Bound_Known flag on this formal.
-
- if Nkind (Expr) = N_Op_Eq then
- declare
- Right : constant Node_Id := Right_Opnd (Expr);
- Left : constant Node_Id := Left_Opnd (Expr);
- begin
- if Nkind (Left) = N_Attribute_Reference
- and then Attribute_Name (Left) = Name_First
- and then Is_Entity_Name (Prefix (Left))
- and then Is_Formal (Entity (Prefix (Left)))
- and then Nkind (Right) = N_Integer_Literal
- then
- Set_Low_Bound_Known (Entity (Prefix (Left)));
- end if;
- end;
- end if;
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => Newa));
+ Analyze (N);
end Assert;
----------------------
-- pragma Assertion_Policy (Check | Ignore)
- when Pragma_Assertion_Policy =>
+ when Pragma_Assertion_Policy => Assertion_Policy : declare
+ Policy : Node_Id;
+
+ begin
Ada_2005_Pragma;
+ Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
+ Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
- Assertions_Enabled := Chars (Expression (Arg1)) = Name_Check;
+
+ -- We treat pragma Assertion_Policy as equivalent to:
+
+ -- pragma Check_Policy (Assertion, policy)
+
+ -- So rewrite the pragma in that manner and link on to the chain
+ -- of Check_Policy pragmas, marking the pragma as analyzed.
+
+ Policy := Get_Pragma_Arg (Arg1);
+
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check_Policy,
+
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Name_Assertion)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Sloc (Policy),
+ Chars => Chars (Policy))))));
+
+ Set_Analyzed (N);
+ Set_Next_Pragma (N, Opt.Check_Policy_List);
+ Opt.Check_Policy_List := N;
+ end Assertion_Policy;
---------------
-- AST_Entry --
New_Copy_Tree (Expression (Arg2));
begin
Set_Parent (Temp, N);
- Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
+ Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
end;
else
end if;
end C_Pass_By_Copy;
+ -----------
+ -- Check --
+ -----------
+
+ -- pragma Check ([Name =>] Identifier,
+ -- [Check =>] Boolean_Expression
+ -- [,[Message =>] String_Expression]);
+
+ when Pragma_Check => Check : declare
+ Expr : Node_Id;
+ Eloc : Source_Ptr;
+
+ Check_On : Boolean;
+ -- Set True if category of assertions referenced by Name enabled
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (3);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Optional_Identifier (Arg2, Name_Check);
+
+ if Arg_Count = 3 then
+ Check_Optional_Identifier (Arg3, Name_Message);
+ Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
+ end if;
+
+ Check_Arg_Is_Identifier (Arg1);
+ Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
+
+ -- If expansion is active and the check is not enabled then we
+ -- rewrite the Check as:
+
+ -- if False and then condition then
+ -- null;
+ -- end if;
+
+ -- The reason we do this rewriting during semantic analysis rather
+ -- than as part of normal expansion is that we cannot analyze and
+ -- expand the code for the boolean expression directly, or it may
+ -- cause insertion of actions that would escape the attempt to
+ -- suppress the check code.
+
+ -- Note that the Sloc for the if statement corresponds to the
+ -- argument condition, not the pragma itself. The reason for this
+ -- is that we may generate a warning if the condition is False at
+ -- compile time, and we do not want to delete this warning when we
+ -- delete the if statement.
+
+ Expr := Expression (Arg2);
+
+ if Expander_Active and then not Check_On then
+ Eloc := Sloc (Expr);
+
+ Rewrite (N,
+ Make_If_Statement (Eloc,
+ Condition =>
+ Make_And_Then (Eloc,
+ Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
+ Right_Opnd => Expr),
+ Then_Statements => New_List (
+ Make_Null_Statement (Eloc))));
+
+ Analyze (N);
+
+ -- Check is active
+
+ else
+ Analyze_And_Resolve (Expr, Any_Boolean);
+ end if;
+
+ -- If assertion is of the form (X'First = literal), where X is
+ -- a formal, then set Low_Bound_Known flag on this formal.
+
+ if Nkind (Expr) = N_Op_Eq then
+ declare
+ Right : constant Node_Id := Right_Opnd (Expr);
+ Left : constant Node_Id := Left_Opnd (Expr);
+ begin
+ if Nkind (Left) = N_Attribute_Reference
+ and then Attribute_Name (Left) = Name_First
+ and then Is_Entity_Name (Prefix (Left))
+ and then Is_Formal (Entity (Prefix (Left)))
+ and then Nkind (Right) = N_Integer_Literal
+ then
+ Set_Low_Bound_Known (Entity (Prefix (Left)));
+ end if;
+ end;
+ end if;
+ end Check;
+
----------------
-- Check_Name --
----------------
Check_Names.Append (Nam);
end;
+ ------------------
+ -- Check_Policy --
+ ------------------
+
+ -- pragma Check_Policy ([Name =>] IDENTIFIER,
+ -- POLICY_IDENTIFIER;
+
+ -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
+
+ -- Note: this is a configuration pragma, but it is allowed to
+ -- appear anywhere else.
+
+ when Pragma_Check_Policy =>
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+ Check_No_Identifier (Arg2);
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Arg_Is_One_Of
+ (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
+
+ -- A Check_Policy pragma can appear either as a configuration
+ -- pragma, or in a declarative part or a package spec (see RM
+ -- 11.5(5) for rules for Suppress/Unsuppress which are also
+ -- followed for Check_Policy).
+
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
+
+ Set_Next_Pragma (N, Opt.Check_Policy_List);
+ Opt.Check_Policy_List := N;
+
---------------------
-- CIL_Constructor --
---------------------
Process_Convention (C, Def_Id);
if Ekind (Def_Id) /= E_Constant then
- Note_Possible_Modification (Expression (Arg2));
+ Note_Possible_Modification (Expression (Arg2), Sure => False);
end if;
Process_Interface_Name (Def_Id, Arg3, Arg4);
Set_Exported (Def_Id, Arg2);
+
+ -- If the entity is a deferred constant, propagate the
+ -- information to the full view, because gigi elaborates
+ -- the full view only.
+
+ if Ekind (Def_Id) = E_Constant
+ and then Present (Full_View (Def_Id))
+ then
+ declare
+ Id2 : constant Entity_Id := Full_View (Def_Id);
+ begin
+ Set_Is_Exported (Id2, Is_Exported (Def_Id));
+ Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
+ Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
+ end;
+ end if;
end Export;
----------------------
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Convention (C, Def_Id);
- Note_Possible_Modification (Expression (Arg2));
+ Note_Possible_Modification (Expression (Arg2), Sure => False);
Process_Interface_Name (Def_Id, Arg3, Arg4);
Set_Exported (Def_Id, Arg2);
end External;
Def_Id := Entity (Id);
end if;
- -- Special DEC-compatible processing for the object case,
- -- forces object to be imported.
+ -- Special DEC-compatible processing for the object case, forces
+ -- object to be imported.
if Ekind (Def_Id) = E_Variable then
Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Id);
+ Note_Possible_Modification (Id, Sure => False);
-- Initialization is not allowed for imported variable
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority));
+ Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
end if;
if Nkind (P) /= N_Task_Definition
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Is_In_Decl_Part_Or_Package_Spec;
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Start_String (Strval (Expr_Value_S (Expression (Arg1))));
+
+ Arg := Arg2;
+ while Present (Arg) loop
+ Check_Arg_Is_Static_Expression (Arg, Standard_String);
+ Store_String_Char (ASCII.NUL);
+ Store_String_Chars (Strval (Expr_Value_S (Expression (Arg))));
+ Arg := Next (Arg);
+ end loop;
if Operating_Mode = Generate_Code
and then In_Extended_Main_Source_Unit (N)
then
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
- Start_String (Strval (Expr_Value_S (Expression (Arg1))));
-
- Arg := Arg2;
- while Present (Arg) loop
- Check_Arg_Is_Static_Expression (Arg, Standard_String);
- Store_String_Char (ASCII.NUL);
- Store_String_Chars
- (Strval (Expr_Value_S (Expression (Arg))));
- Arg := Next (Arg);
- end loop;
-
Store_Linker_Option_String (End_String);
end if;
end Linker_Options;
-- it was misplaced.
when Pragma_No_Body =>
- Error_Pragma ("misplaced pragma %");
+ Pragma_Misplaced;
---------------
-- No_Return --
end if;
end loop;
- Set_Obsolescent_Warning (Ent, Expression (Arg1));
+ Obsolescent_Warnings.Append
+ ((Ent => Ent, Msg => Strval (Expression (Arg1))));
-- Check for Ada_05 parameter
end case;
end;
+ -- Set indication that mode is set locally. If we are in fact in a
+ -- configuration pragma file, this setting is harmless since the
+ -- switch will get reset anyway at the start of each unit.
+
+ Optimize_Alignment_Local := True;
+
----------
-- Pack --
----------
end if;
end Persistent_BSS;
+ -------------------
+ -- Postcondition --
+ -------------------
+
+ -- pragma Postcondition ([Check =>] Boolean_Expression
+ -- [,[Message =>] String_Expression]);
+
+ when Pragma_Postcondition => Postcondition : declare
+ In_Body : Boolean;
+ pragma Warnings (Off, In_Body);
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_Optional_Identifier (Arg1, Name_Check);
+
+ -- All we need to do here is call the common check procedure,
+ -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
+
+ Check_Precondition_Postcondition (In_Body);
+ end Postcondition;
+
+ ------------------
+ -- Precondition --
+ ------------------
+
+ -- pragma Precondition ([Check =>] Boolean_Expression
+ -- [,[Message =>] String_Expression]);
+
+ when Pragma_Precondition => Precondition : declare
+ In_Body : Boolean;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
+ Check_Optional_Identifier (Arg1, Name_Check);
+
+ Check_Precondition_Postcondition (In_Body);
+
+ -- If in spec, nothing to do. If in body, then we convert the
+ -- pragma to pragma Check (Precondition, cond [, msg]). Note we
+ -- do this whether or not precondition checks are enabled. That
+ -- works fine since pragma Check will do this check.
+
+ if In_Body then
+ if Arg_Count = 2 then
+ Check_Optional_Identifier (Arg3, Name_Message);
+ Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
+ end if;
+
+ Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ Rewrite (N,
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Name_Precondition)),
+
+ Make_Pragma_Argument_Association (Sloc (Arg1),
+ Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
+
+ if Arg_Count = 2 then
+ Append_To (Pragma_Argument_Associations (N),
+ Make_Pragma_Argument_Association (Sloc (Arg2),
+ Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
+ end if;
+
+ Analyze (N);
+ end if;
+ end Precondition;
+
------------------
-- Preelaborate --
------------------
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
- Analyze_Per_Use_Expression (Arg, Standard_Integer);
+ Preanalyze_Spec_Expression (Arg, Standard_Integer);
if not Is_Static_Expression (Arg) then
Check_Restriction (Static_Priorities, Arg);
-- pragma Profile (profile_IDENTIFIER);
- -- profile_IDENTIFIER => Protected | Ravenscar
+ -- profile_IDENTIFIER => Restricted | Ravenscar
when Pragma_Profile =>
Ada_2005_Pragma;
-- pragma Profile_Warnings (profile_IDENTIFIER);
- -- profile_IDENTIFIER => Protected | Ravenscar
+ -- profile_IDENTIFIER => Restricted | Ravenscar
when Pragma_Profile_Warnings =>
GNAT_Pragma;
end if;
end;
+ -----------------------
+ -- Relative_Deadline --
+ -----------------------
+
+ -- pragma Relative_Deadline (time_span_EXPRESSION);
+
+ when Pragma_Relative_Deadline => Relative_Deadline : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Ada_2005_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ Arg := Expression (Arg1);
+
+ -- The expression must be analyzed in the special manner described
+ -- in "Handling of Default and Per-Object Expressions" in sem.ads.
+
+ Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
+
+ -- Subprogram case
+
+ if Nkind (P) = N_Subprogram_Body then
+ Check_In_Main_Program;
+
+ -- Tasks
+
+ elsif Nkind (P) = N_Task_Definition then
+ null;
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
+
+ if Has_Relative_Deadline_Pragma (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Relative_Deadline_Pragma (P, True);
+
+ if Nkind (P) = N_Task_Definition then
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
+ end if;
+ end Relative_Deadline;
+
---------------------------
-- Remote_Call_Interface --
---------------------------
-- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restriction_Warnings =>
+ GNAT_Pragma;
Process_Restrictions_Or_Restriction_Warnings (Warn => True);
----------------
Check_No_Identifiers;
Check_Arg_Count (1);
- -- The expression must be analyzed in the special manner
- -- described in "Handling of Default Expressions" in sem.ads.
-
- -- Set In_Default_Expression for per-object case ???
+ -- The expression must be analyzed in the special manner described
+ -- in "Handling of Default Expressions" in sem.ads.
Arg := Expression (Arg1);
- Analyze_Per_Use_Expression (Arg, Any_Integer);
+ Preanalyze_Spec_Expression (Arg, Any_Integer);
if not Is_Static_Expression (Arg) then
Check_Restriction (Static_Storage_Size, Arg);
Write : constant Entity_Id := Entity (Expression (Arg3));
begin
- if Etype (Typ) = Any_Type
- or else
- Etype (Read) = Any_Type
+ Check_First_Subtype (Arg1);
+
+ -- Check for too early or too late. Note that we don't enforce
+ -- the rule about primitive operations in this case, since, as
+ -- is the case for explicit stream attributes themselves, these
+ -- restrictions are not appropriate. Note that the chaining of
+ -- the pragma by Rep_Item_Too_Late is actually the critical
+ -- processing done for this pragma.
+
+ if Rep_Item_Too_Early (Typ, N)
or else
- Etype (Write) = Any_Type
+ Rep_Item_Too_Late (Typ, N, FOnly => True)
then
return;
end if;
- Check_First_Subtype (Arg1);
+ -- Return if previous error
- if Rep_Item_Too_Early (Typ, N)
+ if Etype (Typ) = Any_Type
+ or else
+ Etype (Read) = Any_Type
or else
- Rep_Item_Too_Late (Typ, N)
+ Etype (Write) = Any_Type
then
return;
end if;
+ -- Error checks
+
if Underlying_Type (Etype (Read)) /= Typ then
Error_Pragma_Arg
("incorrect return type for function&", Arg2);
-- pragma Task_Name (string_EXPRESSION);
when Pragma_Task_Name => Task_Name : declare
- -- pragma Priority (EXPRESSION);
-
P : constant Node_Id := Parent (N);
Arg : Node_Id;
when Pragma_Exit => null;
end Analyze_Pragma;
+ -------------------
+ -- Check_Enabled --
+ -------------------
+
+ function Check_Enabled (Nam : Name_Id) return Boolean is
+ PP : Node_Id;
+
+ begin
+ PP := Opt.Check_Policy_List;
+ loop
+ if No (PP) then
+ return Assertions_Enabled;
+
+ elsif
+ Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
+ then
+ case
+ Chars (Expression (Last (Pragma_Argument_Associations (PP))))
+ is
+ when Name_On | Name_Check =>
+ return True;
+ when Name_Off | Name_Ignore =>
+ return False;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ else
+ PP := Next_Pragma (PP);
+ end if;
+ end loop;
+ end Check_Enabled;
+
---------------------------------
-- Delay_Config_Pragma_Analyze --
---------------------------------
return Result;
end Get_Base_Subprogram;
+ --------------------
+ -- Get_Pragma_Arg --
+ --------------------
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
+ begin
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end Get_Pragma_Arg;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Externals.Init;
+ end Initialize;
+
-----------------------------
-- Is_Config_Static_String --
-----------------------------
-- than appearence as any argument is insignificant, a positive value
-- indicates that appearence in that parameter position is significant.
- Sig_Flags : constant array (Pragma_Id) of Int :=
+ -- A value of 99 flags a special case requiring a special check (this is
+ -- used for cases not covered by this standard encoding, e.g. pragma Check
+ -- where the first argument is not significant, but the others are).
+ Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
+ Pragma_Check => 99,
Pragma_Check_Name => 0,
+ Pragma_Check_Policy => 0,
Pragma_CIL_Constructor => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_Preelaborable_Initialization => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
+ Pragma_Postcondition => -1,
+ Pragma_Precondition => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
+ Pragma_Relative_Deadline => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Unknown_Pragma => 0);
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
- P : Node_Id;
- C : Int;
- A : Node_Id;
+ Id : Pragma_Id;
+ P : Node_Id;
+ C : Int;
+ A : Node_Id;
begin
P := Parent (N);
return False;
else
- C := Sig_Flags (Get_Pragma_Id (Parent (P)));
+ Id := Get_Pragma_Id (Parent (P));
+ C := Sig_Flags (Id);
case C is
when -1 =>
when 0 =>
return True;
+ when 99 =>
+ case Id is
+
+ -- For pragma Check, the first argument is not significant,
+ -- the second and the third (if present) arguments are
+ -- significant.
+
+ when Pragma_Check =>
+ return
+ P = First (Pragma_Argument_Associations (Parent (P)));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
when others =>
A := First (Pragma_Argument_Associations (Parent (P)));
for J in 1 .. C - 1 loop
Next (A);
end loop;
- return A = P;
+ return A = P; -- is this wrong way round ???
end case;
end if;
end Is_Non_Significant_Pragma_Reference;
Set_Entity (Pref, Scop);
end if;
end Set_Unit_Name;
+
end Sem_Prag;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Pragma handling is isolated in a separate package
-- (logically this processing belongs in chapter 4)
+with Namet; use Namet;
with Types; use Types;
package Sem_Prag is
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id);
+ -- Special analyze routine for precondition/postcondition pragma that
+ -- appears within a declarative part where the pragma is associated
+ -- with a subprogram specification. N is the pragma node, and S is the
+ -- entity for the related subprogram. This procedure does a preanalysis
+ -- of the expressions in the pragma as "spec expressions" (see section
+ -- in Sem "Handling of Default and Per-Object Expressions...").
+
procedure Analyze_Pragma (N : Node_Id);
-- Analyze procedure for pragma reference node N
+ function Check_Enabled (Nam : Name_Id) return Boolean;
+ -- This function is used in connection with pragmas Assertion, Check,
+ -- Precondition, and Postcondition to determine if Check pragmas (or
+ -- corresponding Assert, Precondition, or Postcondition pragmas) are
+ -- currently active, as determined by the presence of -gnata on the
+ -- command line (which sets the default), and the appearence of pragmas
+ -- Check_Policy and Assertion_Policy as configuration pragmas either in
+ -- a configuration pragma file, or at the start of the current unit.
+ -- True is returned if the specified check is enabled.
+
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean;
-- N is a pragma appearing in a configuration pragma file. Most such
-- pragmas are analyzed when the file is read, before parsing and analyzing
-- True have their analysis delayed until after the main program is parsed
-- and analyzed.
+ procedure Initialize;
+ -- Initializes data structures used for pragma processing. Must be called
+ -- before analyzing each new main source program.
+
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean;
-- The node N is a node for an entity and the issue is whether the
-- occurrence is a reference for the purposes of giving warnings about
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-- Output additional warning if present
- declare
- W : constant Node_Id := Obsolescent_Warning (E);
-
- begin
- if Present (W) then
-
- -- This is a warning continuation to start on a new line
- Name_Buffer (1) := '\';
- Name_Buffer (2) := '\';
- Name_Buffer (3) := '?';
- Name_Len := 3;
-
- -- Add characters to message, and output message. Note that
- -- we quote every character of the message since we don't
- -- want to process any insertions.
-
- for J in 1 .. String_Length (Strval (W)) loop
- Add_Char_To_Name_Buffer (''');
- Add_Char_To_Name_Buffer
- (Get_Character (Get_String_Char (Strval (W), J)));
- end loop;
-
- Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
+ for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop
+ if Obsolescent_Warnings.Table (J).Ent = E then
+ String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg);
+ Error_Msg_Strlen := Name_Len;
+ Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Error_Msg_N ("\\?~", N);
+ exit;
end if;
- end;
+ end loop;
end Output_Obsolescent_Entity_Warnings;
----------------------------------
when 'C' =>
Warn_On_Unrepped_Components := False;
+ when 'e' =>
+ Address_Clause_Overlay_Warnings := True;
+ Check_Unreferenced := True;
+ Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
+ Elab_Warnings := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Ada_2005_Compatibility := True;
+ Warn_On_All_Unread_Out_Parameters := True;
+ Warn_On_Assertion_Failure := True;
+ Warn_On_Assumed_Low_Bound := True;
+ Warn_On_Bad_Fixed_Value := True;
+ Warn_On_Constant := True;
+ Warn_On_Deleted_Code := True;
+ Warn_On_Dereference := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Hiding := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Non_Local_Exception := True;
+ Warn_On_Object_Renames_Function := True;
+ Warn_On_Obsolescent_Feature := True;
+ Warn_On_Questionable_Missing_Parens := True;
+ Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
+ Warn_On_Unrepped_Components := True;
+ Warn_On_Warnings_Off := True;
+
when 'o' =>
Warn_On_All_Unread_Out_Parameters := True;
when 'O' =>
Warn_On_All_Unread_Out_Parameters := False;
+ when 'p' =>
+ Warn_On_Parameter_Order := True;
+
+ when 'P' =>
+ Warn_On_Parameter_Order := False;
+
when 'r' =>
Warn_On_Object_Renames_Function := True;
Warn_On_Modified_Unread := True;
Warn_On_No_Value_Assigned := True;
Warn_On_Non_Local_Exception := True;
+ Warn_On_Object_Renames_Function := True;
Warn_On_Obsolescent_Feature := True;
+ Warn_On_Parameter_Order := True;
Warn_On_Questionable_Missing_Parens := True;
Warn_On_Redundant_Constructs := True;
- Warn_On_Object_Renames_Function := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unrecognized_Pragma := True;
Warn_On_Unrepped_Components := True;
Warn_On_Non_Local_Exception := False;
Warn_On_Obsolescent_Feature := False;
Warn_On_All_Unread_Out_Parameters := False;
+ Warn_On_Parameter_Order := False;
Warn_On_Questionable_Missing_Parens := False;
Warn_On_Redundant_Constructs := False;
Warn_On_Object_Renames_Function := False;
then
return;
- -- Don't warn in assert pragma, since presumably tests in such
- -- a context are very definitely intended, and might well be
+ -- Don't warn in assert or check pragma, since presumably tests in
+ -- such a context are very definitely intended, and might well be
-- known at compile time. Note that we have to test the original
-- node, since assert pragmas get rewritten at analysis time.
elsif Nkind (Original_Node (P)) = N_Pragma
- and then Pragma_Name (Original_Node (P)) = Name_Assert
+ and then (Pragma_Name (Original_Node (P)) = Name_Assert
+ or else
+ Pragma_Name (Original_Node (P)) = Name_Check)
then
return;
end if;
return Flag11 (N);
end Has_Private_View;
+ function Has_Relative_Deadline_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag9 (N);
+ end Has_Relative_Deadline_Pragma;
+
function Has_Self_Reference
(N : Node_Id) return Boolean is
begin
return Node4 (N);
end Next_Named_Actual;
+ function Next_Pragma
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return Node1 (N);
+ end Next_Pragma;
+
function Next_Rep_Item
(N : Node_Id) return Node_Id is
begin
return Node4 (N);
end Parent_Spec;
+ function PPC_Enabled
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return Flag5 (N);
+ end PPC_Enabled;
+
function Position
(N : Node_Id) return Node_Id is
begin
Set_Flag11 (N, Val);
end Set_Has_Private_View;
+ procedure Set_Has_Relative_Deadline_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag9 (N, Val);
+ end Set_Has_Relative_Deadline_Pragma;
+
procedure Set_Has_Self_Reference
(N : Node_Id; Val : Boolean := True) is
begin
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_Next_Named_Actual;
+ procedure Set_Next_Pragma
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_Node1 (N, Val); -- semantic field, no parent set
+ end Set_Next_Pragma;
+
procedure Set_Next_Rep_Item
(N : Node_Id; Val : Node_Id) is
begin
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_Parent_Spec;
+ procedure Set_PPC_Enabled
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag5 (N, Val);
+ end Set_PPC_Enabled;
+
procedure Set_Position
(N : Node_Id; Val : Node_Id) is
begin
-- elements.
-- All_Others (Flag11-Sem)
- -- Present in an N_Others_Choice node. This flag is set in the case of an
- -- others exception where all exceptions are to be caught, even those
- -- that are not normally handled (in particular the tasking abort
- -- signal). This is used for translation of the at end handler into a
- -- normal exception handler.
+ -- Present in an N_Others_Choice node. This flag is set for an others
+ -- exception where all exceptions are to be caught, even those that are
+ -- not normally handled (in particular the tasking abort signal). This
+ -- is used for translation of the at end handler into a normal exception
+ -- handler.
-- Assignment_OK (Flag15-Sem)
-- This flag is set in a subexpression node for an object, indicating
-- limited type objects (such as tasks), setting discriminant fields,
-- setting tag values, etc. N_Object_Declaration nodes also have this
-- flag defined. Here it is used to indicate that an initialization
- -- expression is valid, even where it would normally not be allowed (e.g.
- -- where the type involved is limited).
+ -- expression is valid, even where it would normally not be allowed
+ -- (e.g. where the type involved is limited).
-- Associated_Node (Node4-Sem)
-- Present in nodes that can denote an entity: identifiers, character
-- literals, operator symbols, expanded names, operator nodes, and
- -- attribute reference nodes (all these nodes have an Entity field). This
- -- field is also present in N_Aggregate, N_Selected_Component, and
+ -- attribute reference nodes (all these nodes have an Entity field).
+ -- This field is also present in N_Aggregate, N_Selected_Component, and
-- N_Extension_Aggregate nodes. This field is used in generic processing
- -- to create links between the generic template and the generic copy. See
- -- Sem_Ch12.Get_Associated_Node for full details. Note that this field
- -- overlaps Entity, which is fine, since, as explained in Sem_Ch12, the
- -- normal function of Entity is not required at the point where the
+ -- to create links between the generic template and the generic copy.
+ -- See Sem_Ch12.Get_Associated_Node for full details. Note that this
+ -- field overlaps Entity, which is fine, since, as explained in Sem_Ch12,
+ -- the normal function of Entity is not required at the point where the
-- Associated_Node is set. Note also, that in generic templates, this
-- means that the Entity field does not necessarily point to an Entity.
-- Since the back end is expected to ignore generic templates, this is
-- harmless.
-- At_End_Proc (Node1)
- -- This field is present in an N_Handled_Sequence_Of_Statements node. It
- -- contains an identifier reference for the cleanup procedure to be
+ -- This field is present in an N_Handled_Sequence_Of_Statements node.
+ -- It contains an identifier reference for the cleanup procedure to be
-- called. See description of this node for further details.
-- Backwards_OK (Flag6-Sem)
- -- A flag present in the N_Assignment_Statement node. It is used only if
- -- the type being assigned is an array type, and is set if analysis
+ -- A flag present in the N_Assignment_Statement node. It is used only
+ -- if the type being assigned is an array type, and is set if analysis
-- determines that it is definitely safe to do the copy backwards, i.e.
-- starting at the highest addressed element. Note that if neither of the
-- flags Forwards_OK or Backwards_OK is set, it means that the front end
-- which is used directly in later calls to the original subprogram.
-- Body_Required (Flag13-Sem)
- -- A flag that appears in the N_Compilation_Unit node indicating that the
- -- corresponding unit requires a body. For the package case, this
+ -- A flag that appears in the N_Compilation_Unit node indicating that
+ -- the corresponding unit requires a body. For the package case, this
-- indicates that a completion is required. In Ada 95, if the flag is not
-- set for the package case, then a body may not be present. In Ada 83,
-- if the flag is not set for the package case, then body is optional.
-- permitted (in Ada 83 or Ada 95).
-- By_Ref (Flag5-Sem)
- -- A flag present in N_Simple_Return_Statement and
- -- N_Extended_Return_Statement.
- -- It is set when the returned expression is already allocated on the
- -- secondary stack and thus the result is passed by reference rather
+ -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement,
+ -- this flag is set when the returned expression is already allocated on
+ -- the secondary stack and thus the result is passed by reference rather
-- than copied another time.
-- Check_Address_Alignment (Flag11-Sem)
-- Comes_From_Extended_Return_Statement (Flag18-Sem)
-- Present in N_Simple_Return_Statement nodes. True if this node was
- -- constructed as part of the expansion of an
- -- N_Extended_Return_Statement.
+ -- constructed as part of the N_Extended_Return_Statement expansion.
+ -- .
-- Compile_Time_Known_Aggregate (Flag18-Sem)
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- Condition_Actions (List3-Sem)
-- This field appears in else-if nodes and in the iteration scheme node
-- for while loops. This field is only used during semantic processing to
- -- temporarily hold actions inserted into the tree. In the tree passed to
- -- gigi, the condition actions field is always set to No_List. For
+ -- temporarily hold actions inserted into the tree. In the tree passed
+ -- to gigi, the condition actions field is always set to No_List. For
-- details on how this field is used, see the routine Insert_Actions in
-- package Exp_Util, and also the expansion routines for the relevant
-- nodes.
-- Controlling_Argument (Node1-Sem)
- -- This field is set in procedure and function call nodes if the call is
- -- a dispatching call (it is Empty for a non-dispatching call). It
+ -- This field is set in procedure and function call nodes if the call
+ -- is a dispatching call (it is Empty for a non-dispatching call). It
-- indicates the source of the call's controlling tag. For procedure
-- calls, the Controlling_Argument is one of the actuals. For function
-- that has a dispatching result, it is an entity in the context of the
- -- call that can provide a tag, or else it is the tag of the root type of
- -- the class. It can also specify a tag directly rather than being a
+ -- call that can provide a tag, or else it is the tag of the root type
+ -- of the class. It can also specify a tag directly rather than being a
-- tagged object. The latter is needed by the implementations of AI-239
-- and AI-260.
-- Conversion_OK (Flag14-Sem)
- -- A flag set on type conversion nodes to indicate that the conversion is
- -- to be considered as being valid, even though it is the case that the
- -- conversion is not valid Ada. This is used for Enum_Rep, Fixed_Value
- -- and Integer_Value attributes, for internal conversions done for
+ -- A flag set on type conversion nodes to indicate that the conversion
+ -- is to be considered as being valid, even though it is the case that
+ -- the conversion is not valid Ada. This is used for attributes Enum_Rep,
+ -- Fixed_Value and Integer_Value, for internal conversions done for
-- fixed-point operations, and for certain conversions for calls to
-- initialization procedures. If Conversion_OK is set, then Etype must be
-- set (the analyzer assumes that Etype has been set). For the case of
-- Corresponding_Spec (Node5-Sem)
-- This field is set in subprogram, package, task, and protected body
-- nodes, where it points to the defining entity in the corresponding
- -- spec. The attribute is also set in N_With_Clause nodes, where it
- -- points to the defining entity for the with'ed spec, and in a
- -- subprogram renaming declaration when it is a Renaming_As_Body. The
- -- field is Empty if there is no corresponding spec, as in the case of a
- -- subprogram body that serves as its own spec.
+ -- spec. The attribute is also set in N_With_Clause nodes where it points
+ -- to the defining entity for the with'ed spec, and in a subprogram
+ -- renaming declaration when it is a Renaming_As_Body. The field is Empty
+ -- if there is no corresponding spec, as in the case of a subprogram body
+ -- that serves as its own spec.
-- Corresponding_Stub (Node3-Sem)
-- This field is present in an N_Subunit node. It holds the node in
-- range.
-- Do_Range_Check (Flag9-Sem)
- -- This flag is set on an expression which appears in a context where
- -- a range check is required. The target type is clear from the
- -- context. The contexts in which this flag can appear are limited to
- -- the following.
+ -- This flag is set on an expression which appears in a context where a
+ -- range check is required. The target type is clear from the context.
+ -- The contexts in which this flag can appear are the following:
-- Right side of an assignment. In this case the target type is
-- taken from the left side of the assignment, which is referenced
-- desirable for correct elaboration for this unit.
-- Elaboration_Boolean (Node2-Sem)
- -- This field is present in function and procedure specification
- -- nodes. If set, it points to the entity for a Boolean flag that
- -- must be tested for certain calls to check for access before
- -- elaboration. See body of Sem_Elab for further details. This
- -- field is Empty if no elaboration boolean is required.
+ -- This field is present in function and procedure specification nodes.
+ -- If set, it points to the entity for a Boolean flag that must be tested
+ -- for certain calls to check for access before elaboration. See body of
+ -- Sem_Elab for further details. This field is Empty if no elaboration
+ -- boolean is required.
-- Else_Actions (List3-Sem)
-- This field is present in conditional expression nodes. During code
-- always set to No_List.
-- Enclosing_Variant (Node2-Sem)
- -- This field is present in the N_Variant node and identifies the
- -- Node_Id corresponding to the immediately enclosing variant when
- -- the variant is nested, and N_Empty otherwise. Set during semantic
- -- processing of the variant part of a record type.
+ -- This field is present in the N_Variant node and identifies the Node_Id
+ -- corresponding to the immediately enclosing variant when the variant is
+ -- nested, and N_Empty otherwise. Set during semantic processing of the
+ -- variant part of a record type.
-- Entity (Node4-Sem)
-- Appears in all direct names (identifiers, character literals, and
-- left-hand side of individual assignment to each sub-component.
-- First_Inlined_Subprogram (Node3-Sem)
- -- Present in the N_Compilation_Unit node for the main program. Points to
- -- a chain of entities for subprograms that are to be inlined. The
+ -- Present in the N_Compilation_Unit node for the main program. Points
+ -- to a chain of entities for subprograms that are to be inlined. The
-- Next_Inlined_Subprogram field of these entities is used as a link
- -- pointer with Empty marking the end of the list. This field is Empty if
- -- there are no inlined subprograms or inlining is not active.
+ -- pointer with Empty marking the end of the list. This field is Empty
+ -- if there are no inlined subprograms or inlining is not active.
-- First_Named_Actual (Node4-Sem)
-- Present in procedure call statement and function call nodes, and also
-- First_Subtype_Link (Node5-Sem)
-- Present in N_Freeze_Entity node for an anonymous base type that is
- -- implicitly created by the declaration of a first subtype. It points to
- -- the entity for the first subtype.
+ -- implicitly created by the declaration of a first subtype. It points
+ -- to the entity for the first subtype.
-- Float_Truncate (Flag11-Sem)
-- A flag present in type conversion nodes. This is used for float to
-- with rounding (see Expand_N_Type_Conversion).
-- Forwards_OK (Flag5-Sem)
- -- A flag present in the N_Assignment_Statement node. It is used only if
- -- the type being assigned is an array type, and is set if analysis
+ -- A flag present in the N_Assignment_Statement node. It is used only
+ -- if the type being assigned is an array type, and is set if analysis
-- determines that it is definitely safe to do the copy forwards, i.e.
-- starting at the lowest addressed element. Note that if neither of the
-- flags Forwards_OK or Backwards_OK is set, it means that the front end
-- declarations if the visibility at instantiation is different from the
-- visibility at generic definition.
+ -- Has_Relative_Deadline_Pragma (Flag9-Sem)
+ -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
+ -- flag the presence of a pragma Relative_Deadline.
+
-- Has_Self_Reference (Flag13-Sem)
-- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one
-- of the expressions contains an access attribute reference to the
-- points to the explicit actual parameter itself, not to the
-- N_Parameter_Association node (its parent).
+ -- Next_Pragma (Node1-Sem)
+ -- Present in N_Pragma nodes. Used to create a linked list of pragma
+ -- nodes. Curently used for two purposes:
+ --
+ -- Create a list of linked Check_Policy pragmas. The head of this list
+ -- is stored in Opt.Check_Policy_List (which has further details).
+ --
+ -- Used by processing for Pre/Postcondition pragmas to store a list of
+ -- pragmas associated with the spec of a subprogram (see Sem_Prag for
+ -- details).
+
-- Next_Rep_Item (Node5-Sem)
-- Present in pragma nodes and attribute definition nodes. Used to link
-- representation items that apply to an entity. See description of
-- package specification. This field is Empty for library bodies (the
-- parent spec in this case can be found from the corresponding spec).
+ -- PPC_Enabled (Flag5-Sem)
+ -- Present in N_Pragma nodes. This flag is relevant only for precondition
+ -- and postcondition nodes. It is true if the check corresponding to the
+ -- pragma type is enabled at the point where the pragma appears.
+
-- Present_Expr (Uint3-Sem)
-- Present in an N_Variant node. This has a meaningful value only after
-- Gigi has back annotated the tree with representation information. At
-- N_Pragma
-- Sloc points to pragma identifier
+ -- Next_Pragma (Node1-Sem)
-- Pragma_Argument_Associations (List2) (set to No_List if none)
-- Debug_Statement (Node3) (set to Empty if not Debug, Assert)
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
+ -- PPC_Enabled (Flag5-Sem)
-- Note: we should have a section on what pragmas are passed on to
-- the back end to be processed. This section should note that pragma
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Was_Originally_Stub (Flag13-Sem)
+ -- Has_Relative_Deadline_Pragma (Flag9-Sem)
-----------------------------------
-- 6.4 Procedure Call Statement --
-- Has_Storage_Size_Pragma (Flag5-Sem)
-- Has_Task_Info_Pragma (Flag7-Sem)
-- Has_Task_Name_Pragma (Flag8-Sem)
+ -- Has_Relative_Deadline_Pragma (Flag9-Sem)
--------------------
-- 9.1 Task Item --
N_Null_Statement,
N_Raise_Statement,
N_Requeue_Statement,
- N_Return_Statement, -- renamed as N_Simple_Return_Statement in Sem_Util
+ N_Return_Statement, -- renamed as N_Simple_Return_Statement below
N_Extended_Return_Statement,
N_Selective_Accept,
N_Timed_Entry_Call,
function Has_Private_View
(N : Node_Id) return Boolean; -- Flag11
+ function Has_Relative_Deadline_Pragma
+ (N : Node_Id) return Boolean; -- Flag9
+
function Has_Self_Reference
(N : Node_Id) return Boolean; -- Flag13
function Next_Named_Actual
(N : Node_Id) return Node_Id; -- Node4
+ function Next_Pragma
+ (N : Node_Id) return Node_Id; -- Node1
+
function Next_Rep_Item
(N : Node_Id) return Node_Id; -- Node5
function Parent_Spec
(N : Node_Id) return Node_Id; -- Node4
+ function PPC_Enabled
+ (N : Node_Id) return Boolean; -- Flag5
+
function Position
(N : Node_Id) return Node_Id; -- Node2
procedure Set_Has_Private_View
(N : Node_Id; Val : Boolean := True); -- Flag11
+ procedure Set_Has_Relative_Deadline_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag9
+
procedure Set_Has_Self_Reference
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Next_Named_Actual
(N : Node_Id; Val : Node_Id); -- Node4
+ procedure Set_Next_Pragma
+ (N : Node_Id; Val : Node_Id); -- Node1
+
procedure Set_Next_Rep_Item
(N : Node_Id; Val : Node_Id); -- Node5
procedure Set_Parent_Spec
(N : Node_Id; Val : Node_Id); -- Node4
+ procedure Set_PPC_Enabled
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
procedure Set_Position
(N : Node_Id; Val : Node_Id); -- Node2
5 => False), -- Etype (Node5-Sem)
N_Pragma =>
- (1 => True, -- Chars (Name1)
+ (1 => False, -- Next_Pragma (Node1-Sem)
2 => True, -- Pragma_Argument_Associations (List2)
3 => True, -- Debug_Statement (Node3)
4 => True, -- Pragma_Identifier (Node4)
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Priority_Pragma);
pragma Inline (Has_Private_View);
+ pragma Inline (Has_Relative_Deadline_Pragma);
pragma Inline (Has_Storage_Size_Pragma);
pragma Inline (Has_Task_Info_Pragma);
pragma Inline (Has_Task_Name_Pragma);
pragma Inline (Names);
pragma Inline (Next_Entity);
pragma Inline (Next_Named_Actual);
+ pragma Inline (Next_Pragma);
pragma Inline (Next_Rep_Item);
pragma Inline (Next_Use_Clause);
pragma Inline (No_Ctrl_Actions);
pragma Inline (Parameter_List_Truncated);
pragma Inline (Parameter_Type);
pragma Inline (Parent_Spec);
+ pragma Inline (PPC_Enabled);
pragma Inline (Position);
pragma Inline (Pragma_Argument_Associations);
pragma Inline (Pragma_Identifier);
pragma Inline (Set_Has_No_Elaboration_Code);
pragma Inline (Set_Has_Priority_Pragma);
pragma Inline (Set_Has_Private_View);
+ pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Storage_Size_Pragma);
pragma Inline (Set_Has_Task_Info_Pragma);
pragma Inline (Set_Has_Task_Name_Pragma);
pragma Inline (Set_Names);
pragma Inline (Set_Next_Entity);
pragma Inline (Set_Next_Named_Actual);
+ pragma Inline (Set_Next_Pragma);
+ pragma Inline (Set_Next_Rep_Item);
pragma Inline (Set_Next_Use_Clause);
pragma Inline (Set_No_Ctrl_Actions);
pragma Inline (Set_No_Elaboration_Check);
pragma Inline (Set_Parameter_List_Truncated);
pragma Inline (Set_Parameter_Type);
pragma Inline (Set_Parent_Spec);
+ pragma Inline (Set_PPC_Enabled);
pragma Inline (Set_Position);
pragma Inline (Set_Pragma_Argument_Associations);
pragma Inline (Set_Pragma_Identifier);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
Ptr : Source_Ptr;
begin
- Name_Len := 0;
-
-- Loop through instantiations
Ptr := Loc;
null;
else
+ -- Free the buffer, we use Free here, because we used malloc
+ -- or realloc directly to allocate the tables. That is
+ -- because we were playing the big array trick. We need to
+ -- suppress the warning for freeing from an empty pool!
+
-- We have to recreate a proper pointer to the actual array
-- from the zero origin pointer stored in the source table.
Tmp1 :=
To_Source_Buffer_Ptr
(S.Source_Text (S.Source_First)'Address);
+ pragma Warnings (Off);
Free_Ptr (Tmp1);
-
- -- Note: we are using free here, because we used malloc
- -- or realloc directly to allocate the tables. That is
- -- because we were playing the big array trick.
+ pragma Warnings (On);
if S.Lines_Table /= null then
Memory.Free (To_Address (S.Lines_Table));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- that there definitely is a previous line in the source buffer.
procedure Build_Location_String (Loc : Source_Ptr);
- -- This function builds a string literal of the form "name:line",
- -- where name is the file name corresponding to Loc, and line is
- -- the line number. In the event that instantiations are involved,
- -- additional suffixes of the same form are appended after the
- -- separating string " instantiated at ". The returned string is
- -- stored in Name_Buffer, terminated by ASCII.Nul, with Name_Length
- -- indicating the length not including the terminating Nul.
+ -- This function builds a string literal of the form "name:line", where
+ -- name is the file name corresponding to Loc, and line is the line number.
+ -- In the event that instantiations are involved, additional suffixes of
+ -- the same form are appended after the separating string " instantiated at
+ -- ". The returned string is appended to the Name_Buffer, terminated by
+ -- ASCII.NUL, with Name_Length indicating the length not including the
+ -- terminating Nul.
function Get_Column_Number (P : Source_Ptr) return Column_Number;
-- The ones-origin column number of the specified Source_Ptr value is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
"_local_final_list#" &
"_master#" &
"_object#" &
+ "_postconditions#" &
"_priority#" &
"_process_atsd#" &
+ "_relative_deadline#" &
+ "_result#" &
"_secondary_stack#" &
"_service#" &
"_size#" &
"_call#" &
"rci_name#" &
"receiver#" &
- "result#" &
"rpc#" &
"subp_id#" &
"operation#" &
"assertion_policy#" &
"c_pass_by_copy#" &
"check_name#" &
+ "check_policy#" &
"compile_time_error#" &
"compile_time_warning#" &
"compiler_unit#" &
"no_strict_aliasing#" &
"normalize_scalars#" &
"optimize_alignment#" &
- "polling#" &
"persistent_bss#" &
+ "polling#" &
"priority_specific_dispatching#" &
"profile#" &
"profile_warnings#" &
"atomic#" &
"atomic_components#" &
"attach_handler#" &
+ "check#" &
"cil_constructor#" &
"comment#" &
"common_object#" &
"pack#" &
"page#" &
"passive#" &
+ "postcondition#" &
+ "precondition#" &
"preelaborable_initialization#" &
"preelaborate#" &
"preelaborate_05#" &
"pure#" &
"pure_05#" &
"pure_function#" &
+ "relative_deadline#" &
"remote_call_interface#" &
"remote_types#" &
"share_generic#" &
"dll#" &
"win32#" &
"as_is#" &
+ "assertion#" &
"attribute_name#" &
"body_file_name#" &
"boolean_entry_barriers#" &
- "check#" &
"casing#" &
"code#" &
"component#" &
"emax#" &
"enabled#" &
"enum_rep#" &
+ "enum_val#" &
"epsilon#" &
"exponent#" &
"external_tag#" &
"fore#" &
"has_access_values#" &
"has_discriminants#" &
+ "has_tagged_values#" &
"identity#" &
"img#" &
"integer_value#" &
+ "invalid_value#" &
"large#" &
"last#" &
"last_bit#" &
"priority#" &
"range#" &
"range_length#" &
+ "result#" &
"round#" &
"safe_emax#" &
"safe_first#" &
"priority_queuing#" &
"edf_across_priorities#" &
"fifo_within_priorities#" &
+ "non_preemptive_within_priorities#" &
"round_robin_within_priorities#" &
"access_check#" &
"accessibility_check#" &
"tagged#" &
"raise_exception#" &
"ada_roots#" &
+ "aggregate#" &
"archive_builder#" &
+ "archive_builder_append_option#" &
"archive_indexer#" &
"archive_suffix#" &
"binder#" &
"config_file_unique#" &
"config_spec_file_name#" &
"config_spec_file_name_pattern#" &
+ "configuration#" &
"cross_reference#" &
"default_language#" &
"default_switches#" &
"include_switches#" &
"include_path#" &
"include_path_file#" &
+ "inherit_source_path#" &
"language_kind#" &
"language_processing#" &
"languages#" &
+ "library#" &
"library_ali_dir#" &
"library_auto_init#" &
"library_auto_init_supported#" &
return Pragma_Interface;
elsif N = Name_Priority then
return Pragma_Priority;
+ elsif N = Name_Relative_Deadline then
+ return Pragma_Relative_Deadline;
elsif N = Name_Storage_Size then
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
or else N = Name_AST_Entry
or else N = Name_Fast_Math
or else N = Name_Interface
+ or else N = Name_Relative_Deadline
or else N = Name_Priority
or else N = Name_Storage_Size
or else N = Name_Storage_Unit;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
Name_uLocal_Final_List : constant Name_Id := N + 017;
Name_uMaster : constant Name_Id := N + 018;
Name_uObject : constant Name_Id := N + 019;
- Name_uPriority : constant Name_Id := N + 020;
- Name_uProcess_ATSD : constant Name_Id := N + 021;
- Name_uSecondary_Stack : constant Name_Id := N + 022;
- Name_uService : constant Name_Id := N + 023;
- Name_uSize : constant Name_Id := N + 024;
- Name_uStack : constant Name_Id := N + 025;
- Name_uTags : constant Name_Id := N + 026;
- Name_uTask : constant Name_Id := N + 027;
- Name_uTask_Id : constant Name_Id := N + 028;
- Name_uTask_Info : constant Name_Id := N + 029;
- Name_uTask_Name : constant Name_Id := N + 030;
- Name_uTrace_Sp : constant Name_Id := N + 031;
+ Name_uPostconditions : constant Name_Id := N + 020;
+ Name_uPriority : constant Name_Id := N + 021;
+ Name_uProcess_ATSD : constant Name_Id := N + 022;
+ Name_uRelative_Deadline : constant Name_Id := N + 023;
+ Name_uResult : constant Name_Id := N + 024;
+ Name_uSecondary_Stack : constant Name_Id := N + 025;
+ Name_uService : constant Name_Id := N + 026;
+ Name_uSize : constant Name_Id := N + 027;
+ Name_uStack : constant Name_Id := N + 028;
+ Name_uTags : constant Name_Id := N + 029;
+ Name_uTask : constant Name_Id := N + 030;
+ Name_uTask_Id : constant Name_Id := N + 031;
+ Name_uTask_Info : constant Name_Id := N + 032;
+ Name_uTask_Name : constant Name_Id := N + 033;
+ Name_uTrace_Sp : constant Name_Id := N + 034;
-- Names of predefined primitives used in the expansion of dispatching
-- requeue and select statements, Abort, 'Callable and 'Terminated.
- Name_uDisp_Asynchronous_Select : constant Name_Id := N + 032;
- Name_uDisp_Conditional_Select : constant Name_Id := N + 033;
- Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 034;
- Name_uDisp_Get_Task_Id : constant Name_Id := N + 035;
- Name_uDisp_Requeue : constant Name_Id := N + 036;
- Name_uDisp_Timed_Select : constant Name_Id := N + 037;
+ Name_uDisp_Asynchronous_Select : constant Name_Id := N + 035;
+ Name_uDisp_Conditional_Select : constant Name_Id := N + 036;
+ Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 037;
+ Name_uDisp_Get_Task_Id : constant Name_Id := N + 038;
+ Name_uDisp_Requeue : constant Name_Id := N + 039;
+ Name_uDisp_Timed_Select : constant Name_Id := N + 040;
-- Names of routines in Ada.Finalization, needed by expander
- Name_Initialize : constant Name_Id := N + 038;
- Name_Adjust : constant Name_Id := N + 039;
- Name_Finalize : constant Name_Id := N + 040;
+ Name_Initialize : constant Name_Id := N + 041;
+ Name_Adjust : constant Name_Id := N + 042;
+ Name_Finalize : constant Name_Id := N + 043;
-- Names of fields declared in System.Finalization_Implementation,
-- needed by the expander when generating code for finalization.
- Name_Next : constant Name_Id := N + 041;
- Name_Prev : constant Name_Id := N + 042;
+ Name_Next : constant Name_Id := N + 044;
+ Name_Prev : constant Name_Id := N + 045;
-- Names of TSS routines for implementation of DSA over PolyORB
- Name_uTypeCode : constant Name_Id := N + 043;
- Name_uFrom_Any : constant Name_Id := N + 044;
- Name_uTo_Any : constant Name_Id := N + 045;
+ Name_uTypeCode : constant Name_Id := N + 046;
+ Name_uFrom_Any : constant Name_Id := N + 047;
+ Name_uTo_Any : constant Name_Id := N + 048;
-- Names of allocation routines, also needed by expander
- Name_Allocate : constant Name_Id := N + 046;
- Name_Deallocate : constant Name_Id := N + 047;
- Name_Dereference : constant Name_Id := N + 048;
+ Name_Allocate : constant Name_Id := N + 049;
+ Name_Deallocate : constant Name_Id := N + 050;
+ Name_Dereference : constant Name_Id := N + 051;
-- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
- First_Text_IO_Package : constant Name_Id := N + 049;
- Name_Decimal_IO : constant Name_Id := N + 049;
- Name_Enumeration_IO : constant Name_Id := N + 050;
- Name_Fixed_IO : constant Name_Id := N + 051;
- Name_Float_IO : constant Name_Id := N + 052;
- Name_Integer_IO : constant Name_Id := N + 053;
- Name_Modular_IO : constant Name_Id := N + 054;
- Last_Text_IO_Package : constant Name_Id := N + 054;
+ First_Text_IO_Package : constant Name_Id := N + 052;
+ Name_Decimal_IO : constant Name_Id := N + 052;
+ Name_Enumeration_IO : constant Name_Id := N + 053;
+ Name_Fixed_IO : constant Name_Id := N + 054;
+ Name_Float_IO : constant Name_Id := N + 055;
+ Name_Integer_IO : constant Name_Id := N + 056;
+ Name_Modular_IO : constant Name_Id := N + 057;
+ Last_Text_IO_Package : constant Name_Id := N + 057;
subtype Text_IO_Package_Name is Name_Id
range First_Text_IO_Package .. Last_Text_IO_Package;
-- Some miscellaneous names used for error detection/recovery
- Name_Const : constant Name_Id := N + 055;
- Name_Error : constant Name_Id := N + 056;
- Name_Go : constant Name_Id := N + 057;
- Name_Put : constant Name_Id := N + 058;
- Name_Put_Line : constant Name_Id := N + 059;
- Name_To : constant Name_Id := N + 060;
+ Name_Const : constant Name_Id := N + 058;
+ Name_Error : constant Name_Id := N + 059;
+ Name_Go : constant Name_Id := N + 060;
+ Name_Put : constant Name_Id := N + 061;
+ Name_Put_Line : constant Name_Id := N + 062;
+ Name_To : constant Name_Id := N + 063;
-- Names for packages that are treated specially by the compiler
- Name_Exception_Traces : constant Name_Id := N + 061;
- Name_Finalization : constant Name_Id := N + 062;
- Name_Finalization_Root : constant Name_Id := N + 063;
- Name_Interfaces : constant Name_Id := N + 064;
- Name_Most_Recent_Exception : constant Name_Id := N + 065;
- Name_Standard : constant Name_Id := N + 066;
- Name_System : constant Name_Id := N + 067;
- Name_Text_IO : constant Name_Id := N + 068;
- Name_Wide_Text_IO : constant Name_Id := N + 069;
- Name_Wide_Wide_Text_IO : constant Name_Id := N + 070;
+ Name_Exception_Traces : constant Name_Id := N + 064;
+ Name_Finalization : constant Name_Id := N + 065;
+ Name_Finalization_Root : constant Name_Id := N + 066;
+ Name_Interfaces : constant Name_Id := N + 067;
+ Name_Most_Recent_Exception : constant Name_Id := N + 068;
+ Name_Standard : constant Name_Id := N + 069;
+ Name_System : constant Name_Id := N + 070;
+ Name_Text_IO : constant Name_Id := N + 071;
+ Name_Wide_Text_IO : constant Name_Id := N + 072;
+ Name_Wide_Wide_Text_IO : constant Name_Id := N + 073;
-- Names of implementations of the distributed systems annex
- First_PCS_Name : constant Name_Id := N + 071;
- Name_No_DSA : constant Name_Id := N + 071;
- Name_GARLIC_DSA : constant Name_Id := N + 072;
- Name_PolyORB_DSA : constant Name_Id := N + 073;
- Last_PCS_Name : constant Name_Id := N + 073;
+ First_PCS_Name : constant Name_Id := N + 074;
+ Name_No_DSA : constant Name_Id := N + 074;
+ Name_GARLIC_DSA : constant Name_Id := N + 075;
+ Name_PolyORB_DSA : constant Name_Id := N + 076;
+ Last_PCS_Name : constant Name_Id := N + 076;
subtype PCS_Names is Name_Id
range First_PCS_Name .. Last_PCS_Name;
-- Names of identifiers used in expanding distribution stubs
- Name_Addr : constant Name_Id := N + 074;
- Name_Async : constant Name_Id := N + 075;
- Name_Get_Active_Partition_ID : constant Name_Id := N + 076;
- Name_Get_RCI_Package_Receiver : constant Name_Id := N + 077;
- Name_Get_RCI_Package_Ref : constant Name_Id := N + 078;
- Name_Origin : constant Name_Id := N + 079;
- Name_Params : constant Name_Id := N + 080;
- Name_Partition : constant Name_Id := N + 081;
- Name_Partition_Interface : constant Name_Id := N + 082;
- Name_Ras : constant Name_Id := N + 083;
- Name_uCall : constant Name_Id := N + 084;
- Name_RCI_Name : constant Name_Id := N + 085;
- Name_Receiver : constant Name_Id := N + 086;
- Name_Result : constant Name_Id := N + 087;
- Name_Rpc : constant Name_Id := N + 088;
- Name_Subp_Id : constant Name_Id := N + 089;
- Name_Operation : constant Name_Id := N + 090;
- Name_Argument : constant Name_Id := N + 091;
- Name_Arg_Modes : constant Name_Id := N + 092;
- Name_Handler : constant Name_Id := N + 093;
- Name_Target : constant Name_Id := N + 094;
- Name_Req : constant Name_Id := N + 095;
- Name_Obj_TypeCode : constant Name_Id := N + 096;
- Name_Stub : constant Name_Id := N + 097;
+ Name_Addr : constant Name_Id := N + 077;
+ Name_Async : constant Name_Id := N + 078;
+ Name_Get_Active_Partition_ID : constant Name_Id := N + 079;
+ Name_Get_RCI_Package_Receiver : constant Name_Id := N + 080;
+ Name_Get_RCI_Package_Ref : constant Name_Id := N + 081;
+ Name_Origin : constant Name_Id := N + 082;
+ Name_Params : constant Name_Id := N + 083;
+ Name_Partition : constant Name_Id := N + 084;
+ Name_Partition_Interface : constant Name_Id := N + 085;
+ Name_Ras : constant Name_Id := N + 086;
+ Name_uCall : constant Name_Id := N + 087;
+ Name_RCI_Name : constant Name_Id := N + 088;
+ Name_Receiver : constant Name_Id := N + 089;
+ Name_Rpc : constant Name_Id := N + 090;
+ Name_Subp_Id : constant Name_Id := N + 091;
+ Name_Operation : constant Name_Id := N + 092;
+ Name_Argument : constant Name_Id := N + 093;
+ Name_Arg_Modes : constant Name_Id := N + 094;
+ Name_Handler : constant Name_Id := N + 095;
+ Name_Target : constant Name_Id := N + 096;
+ Name_Req : constant Name_Id := N + 097;
+ Name_Obj_TypeCode : constant Name_Id := N + 098;
+ Name_Stub : constant Name_Id := N + 099;
-- 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 + 098;
- Name_Op_Abs : constant Name_Id := N + 098; -- "abs"
- Name_Op_And : constant Name_Id := N + 099; -- "and"
- Name_Op_Mod : constant Name_Id := N + 100; -- "mod"
- Name_Op_Not : constant Name_Id := N + 101; -- "not"
- Name_Op_Or : constant Name_Id := N + 102; -- "or"
- Name_Op_Rem : constant Name_Id := N + 103; -- "rem"
- Name_Op_Xor : constant Name_Id := N + 104; -- "xor"
- Name_Op_Eq : constant Name_Id := N + 105; -- "="
- Name_Op_Ne : constant Name_Id := N + 106; -- "/="
- Name_Op_Lt : constant Name_Id := N + 107; -- "<"
- Name_Op_Le : constant Name_Id := N + 108; -- "<="
- Name_Op_Gt : constant Name_Id := N + 109; -- ">"
- Name_Op_Ge : constant Name_Id := N + 110; -- ">="
- Name_Op_Add : constant Name_Id := N + 111; -- "+"
- Name_Op_Subtract : constant Name_Id := N + 112; -- "-"
- Name_Op_Concat : constant Name_Id := N + 113; -- "&"
- Name_Op_Multiply : constant Name_Id := N + 114; -- "*"
- Name_Op_Divide : constant Name_Id := N + 115; -- "/"
- Name_Op_Expon : constant Name_Id := N + 116; -- "**"
- Last_Operator_Name : constant Name_Id := N + 116;
+ First_Operator_Name : constant Name_Id := N + 100;
+ Name_Op_Abs : constant Name_Id := N + 100; -- "abs"
+ Name_Op_And : constant Name_Id := N + 101; -- "and"
+ Name_Op_Mod : constant Name_Id := N + 102; -- "mod"
+ Name_Op_Not : constant Name_Id := N + 103; -- "not"
+ Name_Op_Or : constant Name_Id := N + 104; -- "or"
+ Name_Op_Rem : constant Name_Id := N + 105; -- "rem"
+ Name_Op_Xor : constant Name_Id := N + 106; -- "xor"
+ Name_Op_Eq : constant Name_Id := N + 107; -- "="
+ Name_Op_Ne : constant Name_Id := N + 108; -- "/="
+ Name_Op_Lt : constant Name_Id := N + 109; -- "<"
+ Name_Op_Le : constant Name_Id := N + 110; -- "<="
+ Name_Op_Gt : constant Name_Id := N + 111; -- ">"
+ Name_Op_Ge : constant Name_Id := N + 112; -- ">="
+ Name_Op_Add : constant Name_Id := N + 113; -- "+"
+ Name_Op_Subtract : constant Name_Id := N + 114; -- "-"
+ Name_Op_Concat : constant Name_Id := N + 115; -- "&"
+ Name_Op_Multiply : constant Name_Id := N + 116; -- "*"
+ Name_Op_Divide : constant Name_Id := N + 117; -- "/"
+ Name_Op_Expon : constant Name_Id := N + 118; -- "**"
+ Last_Operator_Name : constant Name_Id := N + 118;
-- 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 + 117;
+ First_Pragma_Name : constant Name_Id := N + 119;
-- Configuration pragmas are grouped at start
- Name_Ada_83 : constant Name_Id := N + 117; -- GNAT
- Name_Ada_95 : constant Name_Id := N + 118; -- GNAT
- Name_Ada_05 : constant Name_Id := N + 119; -- GNAT
- Name_Ada_2005 : constant Name_Id := N + 120; -- GNAT
- Name_Assertion_Policy : constant Name_Id := N + 121; -- Ada 05
- Name_C_Pass_By_Copy : constant Name_Id := N + 122; -- GNAT
- Name_Check_Name : constant Name_Id := N + 123; -- GNAT
- Name_Compile_Time_Error : constant Name_Id := N + 124; -- GNAT
- Name_Compile_Time_Warning : constant Name_Id := N + 125; -- GNAT
- Name_Compiler_Unit : constant Name_Id := N + 126; -- GNAT
- Name_Component_Alignment : constant Name_Id := N + 127; -- GNAT
- Name_Convention_Identifier : constant Name_Id := N + 128; -- GNAT
- Name_Debug_Policy : constant Name_Id := N + 129; -- GNAT
- Name_Detect_Blocking : constant Name_Id := N + 130; -- Ada 05
- Name_Discard_Names : constant Name_Id := N + 131;
- Name_Elaboration_Checks : constant Name_Id := N + 132; -- GNAT
- Name_Eliminate : constant Name_Id := N + 133; -- GNAT
- Name_Extend_System : constant Name_Id := N + 134; -- GNAT
- Name_Extensions_Allowed : constant Name_Id := N + 135; -- GNAT
- Name_External_Name_Casing : constant Name_Id := N + 136; -- GNAT
- Name_Favor_Top_Level : constant Name_Id := N + 137; -- GNAT
+ Name_Ada_83 : constant Name_Id := N + 119; -- GNAT
+ Name_Ada_95 : constant Name_Id := N + 120; -- GNAT
+ Name_Ada_05 : constant Name_Id := N + 121; -- GNAT
+ Name_Ada_2005 : constant Name_Id := N + 122; -- GNAT
+ Name_Assertion_Policy : constant Name_Id := N + 123; -- Ada 05
+ Name_C_Pass_By_Copy : constant Name_Id := N + 124; -- GNAT
+ Name_Check_Name : constant Name_Id := N + 125; -- GNAT
+ Name_Check_Policy : constant Name_Id := N + 126; -- GNAT
+ Name_Compile_Time_Error : constant Name_Id := N + 127; -- GNAT
+ Name_Compile_Time_Warning : constant Name_Id := N + 128; -- GNAT
+ Name_Compiler_Unit : constant Name_Id := N + 129; -- GNAT
+ Name_Component_Alignment : constant Name_Id := N + 130; -- GNAT
+ Name_Convention_Identifier : constant Name_Id := N + 131; -- GNAT
+ Name_Debug_Policy : constant Name_Id := N + 132; -- GNAT
+ Name_Detect_Blocking : constant Name_Id := N + 133; -- Ada 05
+ Name_Discard_Names : constant Name_Id := N + 134;
+ Name_Elaboration_Checks : constant Name_Id := N + 135; -- GNAT
+ Name_Eliminate : constant Name_Id := N + 136; -- GNAT
+ Name_Extend_System : constant Name_Id := N + 137; -- GNAT
+ Name_Extensions_Allowed : constant Name_Id := N + 138; -- GNAT
+ Name_External_Name_Casing : constant Name_Id := N + 139; -- GNAT
-- Note: Fast_Math is not in this list because its name matches -- GNAT
-- the name of the corresponding attribute. However, it is
-- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and
-- correctly recognize and process Fast_Math.
- Name_Float_Representation : constant Name_Id := N + 138; -- GNAT
- Name_Implicit_Packing : constant Name_Id := N + 139; -- GNAT
- Name_Initialize_Scalars : constant Name_Id := N + 140; -- GNAT
- Name_Interrupt_State : constant Name_Id := N + 141; -- GNAT
- Name_License : constant Name_Id := N + 142; -- GNAT
- Name_Locking_Policy : constant Name_Id := N + 143;
- Name_Long_Float : constant Name_Id := N + 144; -- VMS
- Name_No_Run_Time : constant Name_Id := N + 145; -- GNAT
- Name_No_Strict_Aliasing : constant Name_Id := N + 146; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 147;
- Name_Optimize_Alignment : constant Name_Id := N + 148; -- GNAT
- Name_Polling : constant Name_Id := N + 149; -- GNAT
- Name_Persistent_BSS : constant Name_Id := N + 150; -- GNAT
- Name_Priority_Specific_Dispatching : constant Name_Id := N + 151; -- Ada 05
- Name_Profile : constant Name_Id := N + 152; -- Ada 05
- Name_Profile_Warnings : constant Name_Id := N + 153; -- GNAT
- Name_Propagate_Exceptions : constant Name_Id := N + 154; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 155;
- Name_Ravenscar : constant Name_Id := N + 156; -- GNAT
- Name_Restricted_Run_Time : constant Name_Id := N + 157; -- GNAT
- Name_Restrictions : constant Name_Id := N + 158;
- Name_Restriction_Warnings : constant Name_Id := N + 159; -- GNAT
- Name_Reviewable : constant Name_Id := N + 160;
- Name_Source_File_Name : constant Name_Id := N + 161; -- GNAT
- Name_Source_File_Name_Project : constant Name_Id := N + 162; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 163; -- GNAT
- Name_Suppress : constant Name_Id := N + 164;
- Name_Suppress_Exception_Locations : constant Name_Id := N + 165; -- GNAT
- Name_Task_Dispatching_Policy : constant Name_Id := N + 166;
- Name_Universal_Data : constant Name_Id := N + 167; -- AAMP
- Name_Unsuppress : constant Name_Id := N + 168; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 169; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 170; -- GNAT
- Name_Warnings : constant Name_Id := N + 171; -- GNAT
- Name_Wide_Character_Encoding : constant Name_Id := N + 172; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 172;
+ Name_Favor_Top_Level : constant Name_Id := N + 140; -- GNAT
+ Name_Float_Representation : constant Name_Id := N + 141; -- GNAT
+ Name_Implicit_Packing : constant Name_Id := N + 142; -- GNAT
+ Name_Initialize_Scalars : constant Name_Id := N + 143; -- GNAT
+ Name_Interrupt_State : constant Name_Id := N + 144; -- GNAT
+ Name_License : constant Name_Id := N + 145; -- GNAT
+ Name_Locking_Policy : constant Name_Id := N + 146;
+ Name_Long_Float : constant Name_Id := N + 147; -- VMS
+ Name_No_Run_Time : constant Name_Id := N + 148; -- GNAT
+ Name_No_Strict_Aliasing : constant Name_Id := N + 149; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 150;
+ Name_Optimize_Alignment : constant Name_Id := N + 151; -- GNAT
+ Name_Persistent_BSS : constant Name_Id := N + 152; -- GNAT
+ Name_Polling : constant Name_Id := N + 153; -- GNAT
+ Name_Priority_Specific_Dispatching : constant Name_Id := N + 154; -- Ada 05
+ Name_Profile : constant Name_Id := N + 155; -- Ada 05
+ Name_Profile_Warnings : constant Name_Id := N + 156; -- GNAT
+ Name_Propagate_Exceptions : constant Name_Id := N + 157; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 158;
+ Name_Ravenscar : constant Name_Id := N + 159; -- GNAT
+ Name_Restricted_Run_Time : constant Name_Id := N + 160; -- GNAT
+ Name_Restrictions : constant Name_Id := N + 161;
+ Name_Restriction_Warnings : constant Name_Id := N + 162; -- GNAT
+ Name_Reviewable : constant Name_Id := N + 163;
+ Name_Source_File_Name : constant Name_Id := N + 164; -- GNAT
+ Name_Source_File_Name_Project : constant Name_Id := N + 165; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 166; -- GNAT
+ Name_Suppress : constant Name_Id := N + 167;
+ Name_Suppress_Exception_Locations : constant Name_Id := N + 168; -- GNAT
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 169;
+ Name_Universal_Data : constant Name_Id := N + 170; -- AAMP
+ Name_Unsuppress : constant Name_Id := N + 171; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 172; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 173; -- GNAT
+ Name_Warnings : constant Name_Id := N + 174; -- GNAT
+ Name_Wide_Character_Encoding : constant Name_Id := N + 175; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 175;
-- Remaining pragma names
- Name_Abort_Defer : constant Name_Id := N + 173; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 174;
- Name_Annotate : constant Name_Id := N + 175; -- GNAT
+ Name_Abort_Defer : constant Name_Id := N + 176; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 177;
+ Name_Annotate : constant Name_Id := N + 178; -- GNAT
-- Note: AST_Entry is not in this list because its name matches -- VMS
-- the name of the corresponding attribute. However, it is
-- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize
-- and process Name_AST_Entry.
- Name_Assert : constant Name_Id := N + 176; -- Ada 05
- Name_Asynchronous : constant Name_Id := N + 177;
- Name_Atomic : constant Name_Id := N + 178;
- Name_Atomic_Components : constant Name_Id := N + 179;
- Name_Attach_Handler : constant Name_Id := N + 180;
- Name_CIL_Constructor : constant Name_Id := N + 181; -- GNAT
- Name_Comment : constant Name_Id := N + 182; -- GNAT
- Name_Common_Object : constant Name_Id := N + 183; -- GNAT
- Name_Complete_Representation : constant Name_Id := N + 184; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 185; -- GNAT
- Name_Controlled : constant Name_Id := N + 186;
- Name_Convention : constant Name_Id := N + 187;
- Name_CPP_Class : constant Name_Id := N + 188; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 189; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 190; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 191; -- GNAT
- Name_Debug : constant Name_Id := N + 192; -- GNAT
- Name_Elaborate : constant Name_Id := N + 193; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 194;
- Name_Elaborate_Body : constant Name_Id := N + 195;
- Name_Export : constant Name_Id := N + 196;
- Name_Export_Exception : constant Name_Id := N + 197; -- VMS
- Name_Export_Function : constant Name_Id := N + 198; -- GNAT
- Name_Export_Object : constant Name_Id := N + 199; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 200; -- GNAT
- Name_Export_Value : constant Name_Id := N + 201; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 202; -- GNAT
- Name_External : constant Name_Id := N + 203; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 204; -- GNAT
- Name_Ident : constant Name_Id := N + 205; -- VMS
- Name_Implemented_By_Entry : constant Name_Id := N + 206; -- Ada 05
- Name_Import : constant Name_Id := N + 207;
- Name_Import_Exception : constant Name_Id := N + 208; -- VMS
- Name_Import_Function : constant Name_Id := N + 209; -- GNAT
- Name_Import_Object : constant Name_Id := N + 210; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 211; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 212; -- GNAT
- Name_Inline : constant Name_Id := N + 213;
- Name_Inline_Always : constant Name_Id := N + 214; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 215; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 216;
- Name_Interface_Name : constant Name_Id := N + 217; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 218;
- Name_Interrupt_Priority : constant Name_Id := N + 219;
- Name_Java_Constructor : constant Name_Id := N + 220; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 221; -- GNAT
- Name_Keep_Names : constant Name_Id := N + 222; -- GNAT
- Name_Link_With : constant Name_Id := N + 223; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 224; -- GNAT
- Name_Linker_Constructor : constant Name_Id := N + 225; -- GNAT
- Name_Linker_Destructor : constant Name_Id := N + 226; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 227;
- Name_Linker_Section : constant Name_Id := N + 228; -- GNAT
- Name_List : constant Name_Id := N + 229;
- Name_Machine_Attribute : constant Name_Id := N + 230; -- GNAT
- Name_Main : constant Name_Id := N + 231; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 232; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 233; -- Ada 83
- Name_No_Body : constant Name_Id := N + 234; -- GNAT
- Name_No_Return : constant Name_Id := N + 235; -- GNAT
- Name_Obsolescent : constant Name_Id := N + 236; -- GNAT
- Name_Optimize : constant Name_Id := N + 237;
- Name_Pack : constant Name_Id := N + 238;
- Name_Page : constant Name_Id := N + 239;
- Name_Passive : constant Name_Id := N + 240; -- GNAT
- Name_Preelaborable_Initialization : constant Name_Id := N + 241; -- Ada 05
- Name_Preelaborate : constant Name_Id := N + 242;
- Name_Preelaborate_05 : constant Name_Id := N + 243; -- GNAT
+ Name_Assert : constant Name_Id := N + 179; -- Ada 05
+ Name_Asynchronous : constant Name_Id := N + 180;
+ Name_Atomic : constant Name_Id := N + 181;
+ Name_Atomic_Components : constant Name_Id := N + 182;
+ Name_Attach_Handler : constant Name_Id := N + 183;
+ Name_Check : constant Name_Id := N + 184; -- GNAT
+ Name_CIL_Constructor : constant Name_Id := N + 185; -- GNAT
+ Name_Comment : constant Name_Id := N + 186; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 187; -- GNAT
+ Name_Complete_Representation : constant Name_Id := N + 188; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 189; -- GNAT
+ Name_Controlled : constant Name_Id := N + 190;
+ Name_Convention : constant Name_Id := N + 191;
+ Name_CPP_Class : constant Name_Id := N + 192; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 193; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 194; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 195; -- GNAT
+ Name_Debug : constant Name_Id := N + 196; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 197; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 198;
+ Name_Elaborate_Body : constant Name_Id := N + 199;
+ Name_Export : constant Name_Id := N + 200;
+ Name_Export_Exception : constant Name_Id := N + 201; -- VMS
+ Name_Export_Function : constant Name_Id := N + 202; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 203; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 204; -- GNAT
+ Name_Export_Value : constant Name_Id := N + 205; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 206; -- GNAT
+ Name_External : constant Name_Id := N + 207; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 208; -- GNAT
+ Name_Ident : constant Name_Id := N + 209; -- VMS
+ Name_Implemented_By_Entry : constant Name_Id := N + 210; -- Ada 05
+ Name_Import : constant Name_Id := N + 211;
+ Name_Import_Exception : constant Name_Id := N + 212; -- VMS
+ Name_Import_Function : constant Name_Id := N + 213; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 214; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 215; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 216; -- GNAT
+ Name_Inline : constant Name_Id := N + 217;
+ Name_Inline_Always : constant Name_Id := N + 218; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 219; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 220;
+ Name_Interface_Name : constant Name_Id := N + 221; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 222;
+ Name_Interrupt_Priority : constant Name_Id := N + 223;
+ Name_Java_Constructor : constant Name_Id := N + 224; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 225; -- GNAT
+ Name_Keep_Names : constant Name_Id := N + 226; -- GNAT
+ Name_Link_With : constant Name_Id := N + 227; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 228; -- GNAT
+ Name_Linker_Constructor : constant Name_Id := N + 229; -- GNAT
+ Name_Linker_Destructor : constant Name_Id := N + 230; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 231;
+ Name_Linker_Section : constant Name_Id := N + 232; -- GNAT
+ Name_List : constant Name_Id := N + 233;
+ Name_Machine_Attribute : constant Name_Id := N + 234; -- GNAT
+ Name_Main : constant Name_Id := N + 235; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 236; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 237; -- Ada 83
+ Name_No_Body : constant Name_Id := N + 238; -- GNAT
+ Name_No_Return : constant Name_Id := N + 239; -- GNAT
+ Name_Obsolescent : constant Name_Id := N + 240; -- GNAT
+ Name_Optimize : constant Name_Id := N + 241;
+ Name_Pack : constant Name_Id := N + 242;
+ Name_Page : constant Name_Id := N + 243;
+ Name_Passive : constant Name_Id := N + 244; -- GNAT
+ Name_Postcondition : constant Name_Id := N + 245; -- GNAT
+ Name_Precondition : constant Name_Id := N + 246; -- GNAT
+ Name_Preelaborable_Initialization : constant Name_Id := N + 247; -- Ada 05
+ Name_Preelaborate : constant Name_Id := N + 248;
+ Name_Preelaborate_05 : constant Name_Id := N + 249; -- GNAT
-- Note: Priority is not in this list because its name matches
-- the name of the corresponding attribute. However, it is
-- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize
-- and process Priority. Priority is a standard Ada 95 pragma.
- Name_Psect_Object : constant Name_Id := N + 244; -- VMS
- Name_Pure : constant Name_Id := N + 245;
- Name_Pure_05 : constant Name_Id := N + 246; -- GNAT
- Name_Pure_Function : constant Name_Id := N + 247; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 248;
- Name_Remote_Types : constant Name_Id := N + 249;
- Name_Share_Generic : constant Name_Id := N + 250; -- GNAT
- Name_Shared : constant Name_Id := N + 251; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 252;
+ Name_Psect_Object : constant Name_Id := N + 250; -- VMS
+ Name_Pure : constant Name_Id := N + 251;
+ Name_Pure_05 : constant Name_Id := N + 252; -- GNAT
+ Name_Pure_Function : constant Name_Id := N + 253; -- GNAT
+ Name_Relative_Deadline : constant Name_Id := N + 254; -- Ada 05
+ Name_Remote_Call_Interface : constant Name_Id := N + 255;
+ Name_Remote_Types : constant Name_Id := N + 256;
+ Name_Share_Generic : constant Name_Id := N + 257; -- GNAT
+ Name_Shared : constant Name_Id := N + 258; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 259;
-- Note: Storage_Size is not in this list because its name
-- matches the name of the corresponding attribute. However,
-- 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 + 253; -- GNAT
- Name_Static_Elaboration_Desired : constant Name_Id := N + 254; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 255; -- GNAT
- Name_Subtitle : constant Name_Id := N + 256; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 257; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 258; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 259; -- GNAT
- Name_System_Name : constant Name_Id := N + 260; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 261; -- GNAT
- Name_Task_Name : constant Name_Id := N + 262; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 263; -- VMS
- Name_Time_Slice : constant Name_Id := N + 264; -- GNAT
- Name_Title : constant Name_Id := N + 265; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 266; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 267; -- GNAT
- Name_Universal_Aliasing : constant Name_Id := N + 268; -- GNAT
- Name_Unmodified : constant Name_Id := N + 269; -- GNAT
- Name_Unreferenced : constant Name_Id := N + 270; -- GNAT
- Name_Unreferenced_Objects : constant Name_Id := N + 271; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 272; -- GNAT
- Name_Volatile : constant Name_Id := N + 273;
- Name_Volatile_Components : constant Name_Id := N + 274;
- Name_Weak_External : constant Name_Id := N + 275; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 275;
+ Name_Source_Reference : constant Name_Id := N + 260; -- GNAT
+ Name_Static_Elaboration_Desired : constant Name_Id := N + 261; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 262; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 263; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 264; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 265; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 266; -- GNAT
+ Name_System_Name : constant Name_Id := N + 267; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 268; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 269; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 270; -- VMS
+ Name_Time_Slice : constant Name_Id := N + 271; -- GNAT
+ Name_Title : constant Name_Id := N + 272; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 273; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 274; -- GNAT
+ Name_Universal_Aliasing : constant Name_Id := N + 275; -- GNAT
+ Name_Unmodified : constant Name_Id := N + 276; -- GNAT
+ Name_Unreferenced : constant Name_Id := N + 277; -- GNAT
+ Name_Unreferenced_Objects : constant Name_Id := N + 278; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 279; -- GNAT
+ Name_Volatile : constant Name_Id := N + 280;
+ Name_Volatile_Components : constant Name_Id := N + 281;
+ Name_Weak_External : constant Name_Id := N + 282; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 282;
-- 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 + 276;
- Name_Ada : constant Name_Id := N + 276;
- Name_Assembler : constant Name_Id := N + 277;
- Name_CIL : constant Name_Id := N + 278;
- Name_COBOL : constant Name_Id := N + 279;
- Name_CPP : constant Name_Id := N + 280;
- Name_Fortran : constant Name_Id := N + 281;
- Name_Intrinsic : constant Name_Id := N + 282;
- Name_Java : constant Name_Id := N + 283;
- Name_Stdcall : constant Name_Id := N + 284;
- Name_Stubbed : constant Name_Id := N + 285;
- Last_Convention_Name : constant Name_Id := N + 285;
+ First_Convention_Name : constant Name_Id := N + 283;
+ Name_Ada : constant Name_Id := N + 283;
+ Name_Assembler : constant Name_Id := N + 284;
+ Name_CIL : constant Name_Id := N + 285;
+ Name_COBOL : constant Name_Id := N + 286;
+ Name_CPP : constant Name_Id := N + 287;
+ Name_Fortran : constant Name_Id := N + 288;
+ Name_Intrinsic : constant Name_Id := N + 289;
+ Name_Java : constant Name_Id := N + 290;
+ Name_Stdcall : constant Name_Id := N + 291;
+ Name_Stubbed : constant Name_Id := N + 292;
+ Last_Convention_Name : constant Name_Id := N + 292;
-- The following names are preset as synonyms for Assembler
- Name_Asm : constant Name_Id := N + 286;
- Name_Assembly : constant Name_Id := N + 287;
+ Name_Asm : constant Name_Id := N + 293;
+ Name_Assembly : constant Name_Id := N + 294;
-- The following names are preset as synonyms for C
- Name_Default : constant Name_Id := N + 288;
+ Name_Default : constant Name_Id := N + 295;
-- Name_Exernal (previously defined as pragma)
-- The following names are preset as synonyms for CPP
- Name_C_Plus_Plus : constant Name_Id := N + 289;
+ Name_C_Plus_Plus : constant Name_Id := N + 296;
-- The following names are present as synonyms for Stdcall
- Name_DLL : constant Name_Id := N + 290;
- Name_Win32 : constant Name_Id := N + 291;
+ Name_DLL : constant Name_Id := N + 297;
+ Name_Win32 : constant Name_Id := N + 298;
-- Other special names used in processing pragmas
- Name_As_Is : constant Name_Id := N + 292;
- Name_Attribute_Name : constant Name_Id := N + 293;
- Name_Body_File_Name : constant Name_Id := N + 294;
- Name_Boolean_Entry_Barriers : constant Name_Id := N + 295;
- Name_Check : constant Name_Id := N + 296;
- Name_Casing : constant Name_Id := N + 297;
- Name_Code : constant Name_Id := N + 298;
- Name_Component : constant Name_Id := N + 299;
- Name_Component_Size_4 : constant Name_Id := N + 300;
- Name_Copy : constant Name_Id := N + 301;
- Name_D_Float : constant Name_Id := N + 302;
- Name_Descriptor : constant Name_Id := N + 303;
- Name_Dot_Replacement : constant Name_Id := N + 304;
- Name_Dynamic : constant Name_Id := N + 305;
- Name_Entity : constant Name_Id := N + 306;
- Name_Entry_Count : constant Name_Id := N + 307;
- Name_External_Name : constant Name_Id := N + 308;
- Name_First_Optional_Parameter : constant Name_Id := N + 309;
- Name_Form : constant Name_Id := N + 310;
- Name_G_Float : constant Name_Id := N + 311;
- Name_Gcc : constant Name_Id := N + 312;
- Name_Gnat : constant Name_Id := N + 313;
- Name_GPL : constant Name_Id := N + 314;
- Name_IEEE_Float : constant Name_Id := N + 315;
- Name_Ignore : constant Name_Id := N + 316;
- Name_Info : constant Name_Id := N + 317;
- Name_Internal : constant Name_Id := N + 318;
- Name_Link_Name : constant Name_Id := N + 319;
- Name_Lowercase : constant Name_Id := N + 320;
- Name_Max_Entry_Queue_Depth : constant Name_Id := N + 321;
- Name_Max_Entry_Queue_Length : constant Name_Id := N + 322;
- Name_Max_Size : constant Name_Id := N + 323;
- Name_Mechanism : constant Name_Id := N + 324;
- Name_Message : constant Name_Id := N + 325;
- Name_Mixedcase : constant Name_Id := N + 326;
- Name_Modified_GPL : constant Name_Id := N + 327;
- Name_Name : constant Name_Id := N + 328;
- Name_NCA : constant Name_Id := N + 329;
- Name_No : constant Name_Id := N + 330;
- Name_No_Dependence : constant Name_Id := N + 331;
- Name_No_Dynamic_Attachment : constant Name_Id := N + 332;
- Name_No_Dynamic_Interrupts : constant Name_Id := N + 333;
- Name_No_Requeue : constant Name_Id := N + 334;
- Name_No_Requeue_Statements : constant Name_Id := N + 335;
- Name_No_Task_Attributes : constant Name_Id := N + 336;
- Name_No_Task_Attributes_Package : constant Name_Id := N + 337;
- Name_On : constant Name_Id := N + 338;
- Name_Parameter_Types : constant Name_Id := N + 339;
- Name_Reference : constant Name_Id := N + 340;
- Name_Restricted : constant Name_Id := N + 341;
- Name_Result_Mechanism : constant Name_Id := N + 342;
- Name_Result_Type : constant Name_Id := N + 343;
- Name_Runtime : constant Name_Id := N + 344;
- Name_SB : constant Name_Id := N + 345;
- Name_Secondary_Stack_Size : constant Name_Id := N + 346;
- Name_Section : constant Name_Id := N + 347;
- Name_Semaphore : constant Name_Id := N + 348;
- Name_Simple_Barriers : constant Name_Id := N + 349;
- Name_Spec_File_Name : constant Name_Id := N + 350;
- Name_State : constant Name_Id := N + 351;
- Name_Static : constant Name_Id := N + 352;
- Name_Stack_Size : constant Name_Id := N + 353;
- Name_Subunit_File_Name : constant Name_Id := N + 354;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 355;
- Name_Task_Type : constant Name_Id := N + 356;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 357;
- Name_Top_Guard : constant Name_Id := N + 358;
- Name_UBA : constant Name_Id := N + 359;
- Name_UBS : constant Name_Id := N + 360;
- Name_UBSB : constant Name_Id := N + 361;
- Name_Unit_Name : constant Name_Id := N + 362;
- Name_Unknown : constant Name_Id := N + 363;
- Name_Unrestricted : constant Name_Id := N + 364;
- Name_Uppercase : constant Name_Id := N + 365;
- Name_User : constant Name_Id := N + 366;
- Name_VAX_Float : constant Name_Id := N + 367;
- Name_VMS : constant Name_Id := N + 368;
- Name_Vtable_Ptr : constant Name_Id := N + 369;
- Name_Working_Storage : constant Name_Id := N + 370;
+ Name_As_Is : constant Name_Id := N + 299;
+ Name_Assertion : constant Name_Id := N + 300;
+ Name_Attribute_Name : constant Name_Id := N + 301;
+ Name_Body_File_Name : constant Name_Id := N + 302;
+ Name_Boolean_Entry_Barriers : constant Name_Id := N + 303;
+ Name_Casing : constant Name_Id := N + 304;
+ Name_Code : constant Name_Id := N + 305;
+ Name_Component : constant Name_Id := N + 306;
+ Name_Component_Size_4 : constant Name_Id := N + 307;
+ Name_Copy : constant Name_Id := N + 308;
+ Name_D_Float : constant Name_Id := N + 309;
+ Name_Descriptor : constant Name_Id := N + 310;
+ Name_Dot_Replacement : constant Name_Id := N + 311;
+ Name_Dynamic : constant Name_Id := N + 312;
+ Name_Entity : constant Name_Id := N + 313;
+ Name_Entry_Count : constant Name_Id := N + 314;
+ Name_External_Name : constant Name_Id := N + 315;
+ Name_First_Optional_Parameter : constant Name_Id := N + 316;
+ Name_Form : constant Name_Id := N + 317;
+ Name_G_Float : constant Name_Id := N + 318;
+ Name_Gcc : constant Name_Id := N + 319;
+ Name_Gnat : constant Name_Id := N + 320;
+ Name_GPL : constant Name_Id := N + 321;
+ Name_IEEE_Float : constant Name_Id := N + 322;
+ Name_Ignore : constant Name_Id := N + 323;
+ Name_Info : constant Name_Id := N + 324;
+ Name_Internal : constant Name_Id := N + 325;
+ Name_Link_Name : constant Name_Id := N + 326;
+ Name_Lowercase : constant Name_Id := N + 327;
+ Name_Max_Entry_Queue_Depth : constant Name_Id := N + 328;
+ Name_Max_Entry_Queue_Length : constant Name_Id := N + 329;
+ Name_Max_Size : constant Name_Id := N + 330;
+ Name_Mechanism : constant Name_Id := N + 331;
+ Name_Message : constant Name_Id := N + 332;
+ Name_Mixedcase : constant Name_Id := N + 333;
+ Name_Modified_GPL : constant Name_Id := N + 334;
+ Name_Name : constant Name_Id := N + 335;
+ Name_NCA : constant Name_Id := N + 336;
+ Name_No : constant Name_Id := N + 337;
+ Name_No_Dependence : constant Name_Id := N + 338;
+ Name_No_Dynamic_Attachment : constant Name_Id := N + 339;
+ Name_No_Dynamic_Interrupts : constant Name_Id := N + 340;
+ Name_No_Requeue : constant Name_Id := N + 341;
+ Name_No_Requeue_Statements : constant Name_Id := N + 342;
+ Name_No_Task_Attributes : constant Name_Id := N + 343;
+ Name_No_Task_Attributes_Package : constant Name_Id := N + 344;
+ Name_On : constant Name_Id := N + 345;
+ Name_Parameter_Types : constant Name_Id := N + 346;
+ Name_Reference : constant Name_Id := N + 347;
+ Name_Restricted : constant Name_Id := N + 348;
+ Name_Result_Mechanism : constant Name_Id := N + 349;
+ Name_Result_Type : constant Name_Id := N + 350;
+ Name_Runtime : constant Name_Id := N + 351;
+ Name_SB : constant Name_Id := N + 352;
+ Name_Secondary_Stack_Size : constant Name_Id := N + 353;
+ Name_Section : constant Name_Id := N + 354;
+ Name_Semaphore : constant Name_Id := N + 355;
+ Name_Simple_Barriers : constant Name_Id := N + 356;
+ Name_Spec_File_Name : constant Name_Id := N + 357;
+ Name_State : constant Name_Id := N + 358;
+ Name_Static : constant Name_Id := N + 359;
+ Name_Stack_Size : constant Name_Id := N + 360;
+ Name_Subunit_File_Name : constant Name_Id := N + 361;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 362;
+ Name_Task_Type : constant Name_Id := N + 363;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 364;
+ Name_Top_Guard : constant Name_Id := N + 365;
+ Name_UBA : constant Name_Id := N + 366;
+ Name_UBS : constant Name_Id := N + 367;
+ Name_UBSB : constant Name_Id := N + 368;
+ Name_Unit_Name : constant Name_Id := N + 369;
+ Name_Unknown : constant Name_Id := N + 370;
+ Name_Unrestricted : constant Name_Id := N + 371;
+ Name_Uppercase : constant Name_Id := N + 372;
+ Name_User : constant Name_Id := N + 373;
+ Name_VAX_Float : constant Name_Id := N + 374;
+ Name_VMS : constant Name_Id := N + 375;
+ Name_Vtable_Ptr : constant Name_Id := N + 376;
+ Name_Working_Storage : constant Name_Id := N + 377;
-- 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 + 371;
- Name_Abort_Signal : constant Name_Id := N + 371; -- GNAT
- Name_Access : constant Name_Id := N + 372;
- Name_Address : constant Name_Id := N + 373;
- Name_Address_Size : constant Name_Id := N + 374; -- GNAT
- Name_Aft : constant Name_Id := N + 375;
- Name_Alignment : constant Name_Id := N + 376;
- Name_Asm_Input : constant Name_Id := N + 377; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 378; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 379; -- VMS
- Name_Bit : constant Name_Id := N + 380; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 381;
- Name_Bit_Position : constant Name_Id := N + 382; -- GNAT
- Name_Body_Version : constant Name_Id := N + 383;
- Name_Callable : constant Name_Id := N + 384;
- Name_Caller : constant Name_Id := N + 385;
- Name_Code_Address : constant Name_Id := N + 386; -- GNAT
- Name_Component_Size : constant Name_Id := N + 387;
- Name_Compose : constant Name_Id := N + 388;
- Name_Constrained : constant Name_Id := N + 389;
- Name_Count : constant Name_Id := N + 390;
- Name_Default_Bit_Order : constant Name_Id := N + 391; -- GNAT
- Name_Definite : constant Name_Id := N + 392;
- Name_Delta : constant Name_Id := N + 393;
- Name_Denorm : constant Name_Id := N + 394;
- Name_Digits : constant Name_Id := N + 395;
- Name_Elaborated : constant Name_Id := N + 396; -- GNAT
- Name_Emax : constant Name_Id := N + 397; -- Ada 83
- Name_Enabled : constant Name_Id := N + 398; -- GNAT
- Name_Enum_Rep : constant Name_Id := N + 399; -- GNAT
- Name_Epsilon : constant Name_Id := N + 400; -- Ada 83
- Name_Exponent : constant Name_Id := N + 401;
- Name_External_Tag : constant Name_Id := N + 402;
- Name_Fast_Math : constant Name_Id := N + 403; -- GNAT
- Name_First : constant Name_Id := N + 404;
- Name_First_Bit : constant Name_Id := N + 405;
- Name_Fixed_Value : constant Name_Id := N + 406; -- GNAT
- Name_Fore : constant Name_Id := N + 407;
- Name_Has_Access_Values : constant Name_Id := N + 408; -- GNAT
- Name_Has_Discriminants : constant Name_Id := N + 409; -- GNAT
- Name_Identity : constant Name_Id := N + 410;
- Name_Img : constant Name_Id := N + 411; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 412; -- GNAT
- Name_Large : constant Name_Id := N + 413; -- Ada 83
- Name_Last : constant Name_Id := N + 414;
- Name_Last_Bit : constant Name_Id := N + 415;
- Name_Leading_Part : constant Name_Id := N + 416;
- Name_Length : constant Name_Id := N + 417;
- Name_Machine_Emax : constant Name_Id := N + 418;
- Name_Machine_Emin : constant Name_Id := N + 419;
- Name_Machine_Mantissa : constant Name_Id := N + 420;
- Name_Machine_Overflows : constant Name_Id := N + 421;
- Name_Machine_Radix : constant Name_Id := N + 422;
- Name_Machine_Rounding : constant Name_Id := N + 423; -- Ada 05
- Name_Machine_Rounds : constant Name_Id := N + 424;
- Name_Machine_Size : constant Name_Id := N + 425; -- GNAT
- Name_Mantissa : constant Name_Id := N + 426; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 427;
- Name_Maximum_Alignment : constant Name_Id := N + 428; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 429; -- GNAT
- Name_Mod : constant Name_Id := N + 430; -- Ada 05
- Name_Model_Emin : constant Name_Id := N + 431;
- Name_Model_Epsilon : constant Name_Id := N + 432;
- Name_Model_Mantissa : constant Name_Id := N + 433;
- Name_Model_Small : constant Name_Id := N + 434;
- Name_Modulus : constant Name_Id := N + 435;
- Name_Null_Parameter : constant Name_Id := N + 436; -- GNAT
- Name_Object_Size : constant Name_Id := N + 437; -- GNAT
- Name_Old : constant Name_Id := N + 438; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 439;
- Name_Passed_By_Reference : constant Name_Id := N + 440; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 441;
- Name_Pos : constant Name_Id := N + 442;
- Name_Position : constant Name_Id := N + 443;
- Name_Priority : constant Name_Id := N + 444; -- Ada 05
- Name_Range : constant Name_Id := N + 445;
- Name_Range_Length : constant Name_Id := N + 446; -- GNAT
- Name_Round : constant Name_Id := N + 447;
- Name_Safe_Emax : constant Name_Id := N + 448; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 449;
- Name_Safe_Large : constant Name_Id := N + 450; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 451;
- Name_Safe_Small : constant Name_Id := N + 452; -- Ada 83
- Name_Scale : constant Name_Id := N + 453;
- Name_Scaling : constant Name_Id := N + 454;
- Name_Signed_Zeros : constant Name_Id := N + 455;
- Name_Size : constant Name_Id := N + 456;
- Name_Small : constant Name_Id := N + 457;
- Name_Storage_Size : constant Name_Id := N + 458;
- Name_Storage_Unit : constant Name_Id := N + 459; -- GNAT
- Name_Stream_Size : constant Name_Id := N + 460; -- Ada 05
- Name_Tag : constant Name_Id := N + 461;
- Name_Target_Name : constant Name_Id := N + 462; -- GNAT
- Name_Terminated : constant Name_Id := N + 463;
- Name_To_Address : constant Name_Id := N + 464; -- GNAT
- Name_Type_Class : constant Name_Id := N + 465; -- GNAT
- Name_UET_Address : constant Name_Id := N + 466; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 467;
- Name_Unchecked_Access : constant Name_Id := N + 468;
- Name_Unconstrained_Array : constant Name_Id := N + 469;
- Name_Universal_Literal_String : constant Name_Id := N + 470; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 471; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 472; -- GNAT
- Name_Val : constant Name_Id := N + 473;
- Name_Valid : constant Name_Id := N + 474;
- Name_Value_Size : constant Name_Id := N + 475; -- GNAT
- Name_Version : constant Name_Id := N + 476;
- Name_Wchar_T_Size : constant Name_Id := N + 477; -- GNAT
- Name_Wide_Wide_Width : constant Name_Id := N + 478; -- Ada 05
- Name_Wide_Width : constant Name_Id := N + 479;
- Name_Width : constant Name_Id := N + 480;
- Name_Word_Size : constant Name_Id := N + 481; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 378;
+ Name_Abort_Signal : constant Name_Id := N + 378; -- GNAT
+ Name_Access : constant Name_Id := N + 379;
+ Name_Address : constant Name_Id := N + 380;
+ Name_Address_Size : constant Name_Id := N + 381; -- GNAT
+ Name_Aft : constant Name_Id := N + 382;
+ Name_Alignment : constant Name_Id := N + 383;
+ Name_Asm_Input : constant Name_Id := N + 384; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 385; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 386; -- VMS
+ Name_Bit : constant Name_Id := N + 387; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 388;
+ Name_Bit_Position : constant Name_Id := N + 389; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 390;
+ Name_Callable : constant Name_Id := N + 391;
+ Name_Caller : constant Name_Id := N + 392;
+ Name_Code_Address : constant Name_Id := N + 393; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 394;
+ Name_Compose : constant Name_Id := N + 395;
+ Name_Constrained : constant Name_Id := N + 396;
+ Name_Count : constant Name_Id := N + 397;
+ Name_Default_Bit_Order : constant Name_Id := N + 398; -- GNAT
+ Name_Definite : constant Name_Id := N + 399;
+ Name_Delta : constant Name_Id := N + 400;
+ Name_Denorm : constant Name_Id := N + 401;
+ Name_Digits : constant Name_Id := N + 402;
+ Name_Elaborated : constant Name_Id := N + 403; -- GNAT
+ Name_Emax : constant Name_Id := N + 404; -- Ada 83
+ Name_Enabled : constant Name_Id := N + 405; -- GNAT
+ Name_Enum_Rep : constant Name_Id := N + 406; -- GNAT
+ Name_Enum_Val : constant Name_Id := N + 407; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 408; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 409;
+ Name_External_Tag : constant Name_Id := N + 410;
+ Name_Fast_Math : constant Name_Id := N + 411; -- GNAT
+ Name_First : constant Name_Id := N + 412;
+ Name_First_Bit : constant Name_Id := N + 413;
+ Name_Fixed_Value : constant Name_Id := N + 414; -- GNAT
+ Name_Fore : constant Name_Id := N + 415;
+ Name_Has_Access_Values : constant Name_Id := N + 416; -- GNAT
+ Name_Has_Discriminants : constant Name_Id := N + 417; -- GNAT
+ Name_Has_Tagged_Values : constant Name_Id := N + 418; -- GNAT
+ Name_Identity : constant Name_Id := N + 419;
+ Name_Img : constant Name_Id := N + 420; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 421; -- GNAT
+ Name_Invalid_Value : constant Name_Id := N + 422; -- GNAT
+ Name_Large : constant Name_Id := N + 423; -- Ada 83
+ Name_Last : constant Name_Id := N + 424;
+ Name_Last_Bit : constant Name_Id := N + 425;
+ Name_Leading_Part : constant Name_Id := N + 426;
+ Name_Length : constant Name_Id := N + 427;
+ Name_Machine_Emax : constant Name_Id := N + 428;
+ Name_Machine_Emin : constant Name_Id := N + 429;
+ Name_Machine_Mantissa : constant Name_Id := N + 430;
+ Name_Machine_Overflows : constant Name_Id := N + 431;
+ Name_Machine_Radix : constant Name_Id := N + 432;
+ Name_Machine_Rounding : constant Name_Id := N + 433; -- Ada 05
+ Name_Machine_Rounds : constant Name_Id := N + 434;
+ Name_Machine_Size : constant Name_Id := N + 435; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 436; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 437;
+ Name_Maximum_Alignment : constant Name_Id := N + 438; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 439; -- GNAT
+ Name_Mod : constant Name_Id := N + 440; -- Ada 05
+ Name_Model_Emin : constant Name_Id := N + 441;
+ Name_Model_Epsilon : constant Name_Id := N + 442;
+ Name_Model_Mantissa : constant Name_Id := N + 443;
+ Name_Model_Small : constant Name_Id := N + 444;
+ Name_Modulus : constant Name_Id := N + 445;
+ Name_Null_Parameter : constant Name_Id := N + 446; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 447; -- GNAT
+ Name_Old : constant Name_Id := N + 448; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 449;
+ Name_Passed_By_Reference : constant Name_Id := N + 450; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 451;
+ Name_Pos : constant Name_Id := N + 452;
+ Name_Position : constant Name_Id := N + 453;
+ Name_Priority : constant Name_Id := N + 454; -- Ada 05
+ Name_Range : constant Name_Id := N + 455;
+ Name_Range_Length : constant Name_Id := N + 456; -- GNAT
+ Name_Result : constant Name_Id := N + 457; -- GNAT
+ Name_Round : constant Name_Id := N + 458;
+ Name_Safe_Emax : constant Name_Id := N + 459; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 460;
+ Name_Safe_Large : constant Name_Id := N + 461; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 462;
+ Name_Safe_Small : constant Name_Id := N + 463; -- Ada 83
+ Name_Scale : constant Name_Id := N + 464;
+ Name_Scaling : constant Name_Id := N + 465;
+ Name_Signed_Zeros : constant Name_Id := N + 466;
+ Name_Size : constant Name_Id := N + 467;
+ Name_Small : constant Name_Id := N + 468;
+ Name_Storage_Size : constant Name_Id := N + 469;
+ Name_Storage_Unit : constant Name_Id := N + 470; -- GNAT
+ Name_Stream_Size : constant Name_Id := N + 471; -- Ada 05
+ Name_Tag : constant Name_Id := N + 472;
+ Name_Target_Name : constant Name_Id := N + 473; -- GNAT
+ Name_Terminated : constant Name_Id := N + 474;
+ Name_To_Address : constant Name_Id := N + 475; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 476; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 477; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 478;
+ Name_Unchecked_Access : constant Name_Id := N + 479;
+ Name_Unconstrained_Array : constant Name_Id := N + 480;
+ Name_Universal_Literal_String : constant Name_Id := N + 481; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 482; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 483; -- GNAT
+ Name_Val : constant Name_Id := N + 484;
+ Name_Valid : constant Name_Id := N + 485;
+ Name_Value_Size : constant Name_Id := N + 486; -- GNAT
+ Name_Version : constant Name_Id := N + 487;
+ Name_Wchar_T_Size : constant Name_Id := N + 488; -- GNAT
+ Name_Wide_Wide_Width : constant Name_Id := N + 489; -- Ada 05
+ Name_Wide_Width : constant Name_Id := N + 490;
+ Name_Width : constant Name_Id := N + 491;
+ Name_Word_Size : constant Name_Id := N + 492; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value and that
-- have non-universal arguments.
- First_Renamable_Function_Attribute : constant Name_Id := N + 482;
- Name_Adjacent : constant Name_Id := N + 482;
- Name_Ceiling : constant Name_Id := N + 483;
- Name_Copy_Sign : constant Name_Id := N + 484;
- Name_Floor : constant Name_Id := N + 485;
- Name_Fraction : constant Name_Id := N + 486;
- Name_Image : constant Name_Id := N + 487;
- Name_Input : constant Name_Id := N + 488;
- Name_Machine : constant Name_Id := N + 489;
- Name_Max : constant Name_Id := N + 490;
- Name_Min : constant Name_Id := N + 491;
- Name_Model : constant Name_Id := N + 492;
- Name_Pred : constant Name_Id := N + 493;
- Name_Remainder : constant Name_Id := N + 494;
- Name_Rounding : constant Name_Id := N + 495;
- Name_Succ : constant Name_Id := N + 496;
- Name_Truncation : constant Name_Id := N + 497;
- Name_Value : constant Name_Id := N + 498;
- Name_Wide_Image : constant Name_Id := N + 499;
- Name_Wide_Wide_Image : constant Name_Id := N + 500;
- Name_Wide_Value : constant Name_Id := N + 501;
- Name_Wide_Wide_Value : constant Name_Id := N + 502;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 502;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 493;
+ Name_Adjacent : constant Name_Id := N + 493;
+ Name_Ceiling : constant Name_Id := N + 494;
+ Name_Copy_Sign : constant Name_Id := N + 495;
+ Name_Floor : constant Name_Id := N + 496;
+ Name_Fraction : constant Name_Id := N + 497;
+ Name_Image : constant Name_Id := N + 498;
+ Name_Input : constant Name_Id := N + 499;
+ Name_Machine : constant Name_Id := N + 500;
+ Name_Max : constant Name_Id := N + 501;
+ Name_Min : constant Name_Id := N + 502;
+ Name_Model : constant Name_Id := N + 503;
+ Name_Pred : constant Name_Id := N + 504;
+ Name_Remainder : constant Name_Id := N + 505;
+ Name_Rounding : constant Name_Id := N + 506;
+ Name_Succ : constant Name_Id := N + 507;
+ Name_Truncation : constant Name_Id := N + 508;
+ Name_Value : constant Name_Id := N + 509;
+ Name_Wide_Image : constant Name_Id := N + 510;
+ Name_Wide_Wide_Image : constant Name_Id := N + 511;
+ Name_Wide_Value : constant Name_Id := N + 512;
+ Name_Wide_Wide_Value : constant Name_Id := N + 513;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 513;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 503;
- Name_Output : constant Name_Id := N + 503;
- Name_Read : constant Name_Id := N + 504;
- Name_Write : constant Name_Id := N + 505;
- Last_Procedure_Attribute : constant Name_Id := N + 505;
+ First_Procedure_Attribute : constant Name_Id := N + 514;
+ Name_Output : constant Name_Id := N + 514;
+ Name_Read : constant Name_Id := N + 515;
+ Name_Write : constant Name_Id := N + 516;
+ Last_Procedure_Attribute : constant Name_Id := N + 516;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 506;
- Name_Elab_Body : constant Name_Id := N + 506; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 507; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 508;
+ First_Entity_Attribute_Name : constant Name_Id := N + 517;
+ Name_Elab_Body : constant Name_Id := N + 517; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 518; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 519;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 509;
- Name_Base : constant Name_Id := N + 509;
- Name_Class : constant Name_Id := N + 510;
- Name_Stub_Type : constant Name_Id := N + 511;
- Last_Type_Attribute_Name : constant Name_Id := N + 511;
- Last_Entity_Attribute_Name : constant Name_Id := N + 511;
- Last_Attribute_Name : constant Name_Id := N + 511;
+ First_Type_Attribute_Name : constant Name_Id := N + 520;
+ Name_Base : constant Name_Id := N + 520;
+ Name_Class : constant Name_Id := N + 521;
+ Name_Stub_Type : constant Name_Id := N + 522;
+ Last_Type_Attribute_Name : constant Name_Id := N + 522;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 522;
+ Last_Attribute_Name : constant Name_Id := N + 522;
-- 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 + 512;
- Name_Ceiling_Locking : constant Name_Id := N + 512;
- Name_Inheritance_Locking : constant Name_Id := N + 513;
- Last_Locking_Policy_Name : constant Name_Id := N + 513;
+ First_Locking_Policy_Name : constant Name_Id := N + 523;
+ Name_Ceiling_Locking : constant Name_Id := N + 523;
+ Name_Inheritance_Locking : constant Name_Id := N + 524;
+ Last_Locking_Policy_Name : constant Name_Id := N + 524;
-- 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 + 514;
- Name_FIFO_Queuing : constant Name_Id := N + 514;
- Name_Priority_Queuing : constant Name_Id := N + 515;
- Last_Queuing_Policy_Name : constant Name_Id := N + 515;
+ First_Queuing_Policy_Name : constant Name_Id := N + 525;
+ Name_FIFO_Queuing : constant Name_Id := N + 525;
+ Name_Priority_Queuing : constant Name_Id := N + 526;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 526;
-- Names of recognized task dispatching policy identifiers
-- name (e.g. F for FIFO_Within_Priorities). If new policy names
-- are added, the first character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + 516;
- Name_EDF_Across_Priorities : constant Name_Id := N + 516;
- Name_FIFO_Within_Priorities : constant Name_Id := N + 517;
- Name_Non_Preemptive_Within_Priorities
- : constant Name_Id := N + 513;
- Name_Round_Robin_Within_Priorities : constant Name_Id := N + 518;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 518;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 527;
+ Name_EDF_Across_Priorities : constant Name_Id := N + 527;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 528;
+ Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + 529;
+ Name_Round_Robin_Within_Priorities : constant Name_Id := N + 530;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 530;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 519;
- Name_Access_Check : constant Name_Id := N + 519;
- Name_Accessibility_Check : constant Name_Id := N + 520;
- Name_Alignment_Check : constant Name_Id := N + 521; -- GNAT
- Name_Discriminant_Check : constant Name_Id := N + 522;
- Name_Division_Check : constant Name_Id := N + 523;
- Name_Elaboration_Check : constant Name_Id := N + 524;
- Name_Index_Check : constant Name_Id := N + 525;
- Name_Length_Check : constant Name_Id := N + 526;
- Name_Overflow_Check : constant Name_Id := N + 527;
- Name_Range_Check : constant Name_Id := N + 528;
- Name_Storage_Check : constant Name_Id := N + 529;
- Name_Tag_Check : constant Name_Id := N + 530;
- Name_Validity_Check : constant Name_Id := N + 531; -- GNAT
- Name_All_Checks : constant Name_Id := N + 532;
- Last_Check_Name : constant Name_Id := N + 532;
+ First_Check_Name : constant Name_Id := N + 531;
+ Name_Access_Check : constant Name_Id := N + 531;
+ Name_Accessibility_Check : constant Name_Id := N + 532;
+ Name_Alignment_Check : constant Name_Id := N + 533; -- GNAT
+ Name_Discriminant_Check : constant Name_Id := N + 534;
+ Name_Division_Check : constant Name_Id := N + 535;
+ Name_Elaboration_Check : constant Name_Id := N + 536;
+ Name_Index_Check : constant Name_Id := N + 537;
+ Name_Length_Check : constant Name_Id := N + 538;
+ Name_Overflow_Check : constant Name_Id := N + 539;
+ Name_Range_Check : constant Name_Id := N + 540;
+ Name_Storage_Check : constant Name_Id := N + 541;
+ Name_Tag_Check : constant Name_Id := N + 542;
+ Name_Validity_Check : constant Name_Id := N + 543; -- GNAT
+ Name_All_Checks : constant Name_Id := N + 544;
+ Last_Check_Name : constant Name_Id := N + 544;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Mod, Range).
- Name_Abort : constant Name_Id := N + 533;
- Name_Abs : constant Name_Id := N + 534;
- Name_Accept : constant Name_Id := N + 535;
- Name_And : constant Name_Id := N + 536;
- Name_All : constant Name_Id := N + 537;
- Name_Array : constant Name_Id := N + 538;
- Name_At : constant Name_Id := N + 539;
- Name_Begin : constant Name_Id := N + 540;
- Name_Body : constant Name_Id := N + 541;
- Name_Case : constant Name_Id := N + 542;
- Name_Constant : constant Name_Id := N + 543;
- Name_Declare : constant Name_Id := N + 544;
- Name_Delay : constant Name_Id := N + 545;
- Name_Do : constant Name_Id := N + 546;
- Name_Else : constant Name_Id := N + 547;
- Name_Elsif : constant Name_Id := N + 548;
- Name_End : constant Name_Id := N + 549;
- Name_Entry : constant Name_Id := N + 550;
- Name_Exception : constant Name_Id := N + 551;
- Name_Exit : constant Name_Id := N + 552;
- Name_For : constant Name_Id := N + 553;
- Name_Function : constant Name_Id := N + 554;
- Name_Generic : constant Name_Id := N + 555;
- Name_Goto : constant Name_Id := N + 556;
- Name_If : constant Name_Id := N + 557;
- Name_In : constant Name_Id := N + 558;
- Name_Is : constant Name_Id := N + 559;
- Name_Limited : constant Name_Id := N + 560;
- Name_Loop : constant Name_Id := N + 561;
- Name_New : constant Name_Id := N + 562;
- Name_Not : constant Name_Id := N + 563;
- Name_Null : constant Name_Id := N + 564;
- Name_Of : constant Name_Id := N + 565;
- Name_Or : constant Name_Id := N + 566;
- Name_Others : constant Name_Id := N + 567;
- Name_Out : constant Name_Id := N + 568;
- Name_Package : constant Name_Id := N + 569;
- Name_Pragma : constant Name_Id := N + 570;
- Name_Private : constant Name_Id := N + 571;
- Name_Procedure : constant Name_Id := N + 572;
- Name_Raise : constant Name_Id := N + 573;
- Name_Record : constant Name_Id := N + 574;
- Name_Rem : constant Name_Id := N + 575;
- Name_Renames : constant Name_Id := N + 576;
- Name_Return : constant Name_Id := N + 577;
- Name_Reverse : constant Name_Id := N + 578;
- Name_Select : constant Name_Id := N + 579;
- Name_Separate : constant Name_Id := N + 580;
- Name_Subtype : constant Name_Id := N + 581;
- Name_Task : constant Name_Id := N + 582;
- Name_Terminate : constant Name_Id := N + 583;
- Name_Then : constant Name_Id := N + 584;
- Name_Type : constant Name_Id := N + 585;
- Name_Use : constant Name_Id := N + 586;
- Name_When : constant Name_Id := N + 587;
- Name_While : constant Name_Id := N + 588;
- Name_With : constant Name_Id := N + 589;
- Name_Xor : constant Name_Id := N + 590;
+ Name_Abort : constant Name_Id := N + 545;
+ Name_Abs : constant Name_Id := N + 546;
+ Name_Accept : constant Name_Id := N + 547;
+ Name_And : constant Name_Id := N + 548;
+ Name_All : constant Name_Id := N + 549;
+ Name_Array : constant Name_Id := N + 550;
+ Name_At : constant Name_Id := N + 551;
+ Name_Begin : constant Name_Id := N + 552;
+ Name_Body : constant Name_Id := N + 553;
+ Name_Case : constant Name_Id := N + 554;
+ Name_Constant : constant Name_Id := N + 555;
+ Name_Declare : constant Name_Id := N + 556;
+ Name_Delay : constant Name_Id := N + 557;
+ Name_Do : constant Name_Id := N + 558;
+ Name_Else : constant Name_Id := N + 559;
+ Name_Elsif : constant Name_Id := N + 560;
+ Name_End : constant Name_Id := N + 561;
+ Name_Entry : constant Name_Id := N + 562;
+ Name_Exception : constant Name_Id := N + 563;
+ Name_Exit : constant Name_Id := N + 564;
+ Name_For : constant Name_Id := N + 565;
+ Name_Function : constant Name_Id := N + 566;
+ Name_Generic : constant Name_Id := N + 567;
+ Name_Goto : constant Name_Id := N + 568;
+ Name_If : constant Name_Id := N + 569;
+ Name_In : constant Name_Id := N + 570;
+ Name_Is : constant Name_Id := N + 571;
+ Name_Limited : constant Name_Id := N + 572;
+ Name_Loop : constant Name_Id := N + 573;
+ Name_New : constant Name_Id := N + 574;
+ Name_Not : constant Name_Id := N + 575;
+ Name_Null : constant Name_Id := N + 576;
+ Name_Of : constant Name_Id := N + 577;
+ Name_Or : constant Name_Id := N + 578;
+ Name_Others : constant Name_Id := N + 579;
+ Name_Out : constant Name_Id := N + 580;
+ Name_Package : constant Name_Id := N + 581;
+ Name_Pragma : constant Name_Id := N + 582;
+ Name_Private : constant Name_Id := N + 583;
+ Name_Procedure : constant Name_Id := N + 584;
+ Name_Raise : constant Name_Id := N + 585;
+ Name_Record : constant Name_Id := N + 586;
+ Name_Rem : constant Name_Id := N + 587;
+ Name_Renames : constant Name_Id := N + 588;
+ Name_Return : constant Name_Id := N + 589;
+ Name_Reverse : constant Name_Id := N + 590;
+ Name_Select : constant Name_Id := N + 591;
+ Name_Separate : constant Name_Id := N + 592;
+ Name_Subtype : constant Name_Id := N + 593;
+ Name_Task : constant Name_Id := N + 594;
+ Name_Terminate : constant Name_Id := N + 595;
+ Name_Then : constant Name_Id := N + 596;
+ Name_Type : constant Name_Id := N + 597;
+ Name_Use : constant Name_Id := N + 598;
+ Name_When : constant Name_Id := N + 599;
+ Name_While : constant Name_Id := N + 600;
+ Name_With : constant Name_Id := N + 601;
+ Name_Xor : constant Name_Id := N + 602;
-- 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 + 591;
- Name_Divide : constant Name_Id := N + 591;
- Name_Enclosing_Entity : constant Name_Id := N + 592;
- Name_Exception_Information : constant Name_Id := N + 593;
- Name_Exception_Message : constant Name_Id := N + 594;
- Name_Exception_Name : constant Name_Id := N + 595;
- Name_File : constant Name_Id := N + 596;
- Name_Generic_Dispatching_Constructor : constant Name_Id := N + 597;
- Name_Import_Address : constant Name_Id := N + 598;
- Name_Import_Largest_Value : constant Name_Id := N + 599;
- Name_Import_Value : constant Name_Id := N + 600;
- Name_Is_Negative : constant Name_Id := N + 601;
- Name_Line : constant Name_Id := N + 602;
- Name_Rotate_Left : constant Name_Id := N + 603;
- Name_Rotate_Right : constant Name_Id := N + 604;
- Name_Shift_Left : constant Name_Id := N + 605;
- Name_Shift_Right : constant Name_Id := N + 606;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 607;
- Name_Source_Location : constant Name_Id := N + 608;
- Name_Unchecked_Conversion : constant Name_Id := N + 609;
- Name_Unchecked_Deallocation : constant Name_Id := N + 610;
- Name_To_Pointer : constant Name_Id := N + 611;
- Last_Intrinsic_Name : constant Name_Id := N + 611;
+ First_Intrinsic_Name : constant Name_Id := N + 603;
+ Name_Divide : constant Name_Id := N + 603;
+ Name_Enclosing_Entity : constant Name_Id := N + 604;
+ Name_Exception_Information : constant Name_Id := N + 605;
+ Name_Exception_Message : constant Name_Id := N + 606;
+ Name_Exception_Name : constant Name_Id := N + 607;
+ Name_File : constant Name_Id := N + 608;
+ Name_Generic_Dispatching_Constructor : constant Name_Id := N + 609;
+ Name_Import_Address : constant Name_Id := N + 610;
+ Name_Import_Largest_Value : constant Name_Id := N + 611;
+ Name_Import_Value : constant Name_Id := N + 612;
+ Name_Is_Negative : constant Name_Id := N + 613;
+ Name_Line : constant Name_Id := N + 614;
+ Name_Rotate_Left : constant Name_Id := N + 615;
+ Name_Rotate_Right : constant Name_Id := N + 616;
+ Name_Shift_Left : constant Name_Id := N + 617;
+ Name_Shift_Right : constant Name_Id := N + 618;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 619;
+ Name_Source_Location : constant Name_Id := N + 620;
+ Name_Unchecked_Conversion : constant Name_Id := N + 621;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 622;
+ Name_To_Pointer : constant Name_Id := N + 623;
+ Last_Intrinsic_Name : constant Name_Id := N + 623;
-- Names used in processing intrinsic calls
- Name_Free : constant Name_Id := N + 612;
+ Name_Free : constant Name_Id := N + 624;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 613;
- Name_Abstract : constant Name_Id := N + 613;
- Name_Aliased : constant Name_Id := N + 614;
- Name_Protected : constant Name_Id := N + 615;
- Name_Until : constant Name_Id := N + 616;
- Name_Requeue : constant Name_Id := N + 617;
- Name_Tagged : constant Name_Id := N + 618;
- Last_95_Reserved_Word : constant Name_Id := N + 618;
+ First_95_Reserved_Word : constant Name_Id := N + 625;
+ Name_Abstract : constant Name_Id := N + 625;
+ Name_Aliased : constant Name_Id := N + 626;
+ Name_Protected : constant Name_Id := N + 627;
+ Name_Until : constant Name_Id := N + 628;
+ Name_Requeue : constant Name_Id := N + 629;
+ Name_Tagged : constant Name_Id := N + 630;
+ Last_95_Reserved_Word : constant Name_Id := N + 630;
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 + 619;
+ Name_Raise_Exception : constant Name_Id := N + 631;
-- Additional reserved words and identifiers used in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Ada_Roots : constant Name_Id := N + 620;
- Name_Archive_Builder : constant Name_Id := N + 621;
- Name_Archive_Indexer : constant Name_Id := N + 622;
- Name_Archive_Suffix : constant Name_Id := N + 623;
- Name_Binder : constant Name_Id := N + 624;
- Name_Binder_Prefix : constant Name_Id := N + 625;
- Name_Body_Suffix : constant Name_Id := N + 626;
- Name_Builder : constant Name_Id := N + 627;
- Name_Builder_Switches : constant Name_Id := N + 628;
- Name_Compiler : constant Name_Id := N + 629;
- Name_Compiler_Kind : constant Name_Id := N + 630;
- Name_Config_Body_File_Name : constant Name_Id := N + 631;
- Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 632;
- Name_Config_File_Switches : constant Name_Id := N + 633;
- Name_Config_File_Unique : constant Name_Id := N + 634;
- Name_Config_Spec_File_Name : constant Name_Id := N + 635;
- Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 636;
- Name_Cross_Reference : constant Name_Id := N + 637;
- Name_Default_Language : constant Name_Id := N + 638;
- Name_Default_Switches : constant Name_Id := N + 639;
- Name_Dependency_Driver : constant Name_Id := N + 640;
- Name_Dependency_File_Kind : constant Name_Id := N + 641;
- Name_Dependency_Switches : constant Name_Id := N + 642;
- Name_Driver : constant Name_Id := N + 643;
- Name_Excluded_Source_Dirs : constant Name_Id := N + 644;
- Name_Excluded_Source_Files : constant Name_Id := N + 645;
- Name_Exec_Dir : constant Name_Id := N + 646;
- Name_Executable : constant Name_Id := N + 647;
- Name_Executable_Suffix : constant Name_Id := N + 648;
- Name_Extends : constant Name_Id := N + 649;
- Name_Externally_Built : constant Name_Id := N + 650;
- Name_Finder : constant Name_Id := N + 651;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 652;
- Name_Global_Config_File : constant Name_Id := N + 653;
- Name_Gnatls : constant Name_Id := N + 654;
- Name_Gnatstub : constant Name_Id := N + 655;
- Name_Implementation : constant Name_Id := N + 656;
- Name_Implementation_Exceptions : constant Name_Id := N + 657;
- Name_Implementation_Suffix : constant Name_Id := N + 658;
- Name_Include_Switches : constant Name_Id := N + 659;
- Name_Include_Path : constant Name_Id := N + 660;
- Name_Include_Path_File : constant Name_Id := N + 661;
- Name_Language_Kind : constant Name_Id := N + 662;
- Name_Language_Processing : constant Name_Id := N + 663;
- Name_Languages : constant Name_Id := N + 664;
- Name_Library_Ali_Dir : constant Name_Id := N + 665;
- Name_Library_Auto_Init : constant Name_Id := N + 666;
- Name_Library_Auto_Init_Supported : constant Name_Id := N + 667;
- Name_Library_Builder : constant Name_Id := N + 668;
- Name_Library_Dir : constant Name_Id := N + 669;
- Name_Library_GCC : constant Name_Id := N + 670;
- Name_Library_Interface : constant Name_Id := N + 671;
- Name_Library_Kind : constant Name_Id := N + 672;
- Name_Library_Name : constant Name_Id := N + 673;
- Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 674;
- Name_Library_Options : constant Name_Id := N + 675;
- Name_Library_Partial_Linker : constant Name_Id := N + 676;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 677;
- Name_Library_Src_Dir : constant Name_Id := N + 678;
- Name_Library_Support : constant Name_Id := N + 679;
- Name_Library_Symbol_File : constant Name_Id := N + 680;
- Name_Library_Symbol_Policy : constant Name_Id := N + 681;
- Name_Library_Version : constant Name_Id := N + 682;
- Name_Library_Version_Switches : constant Name_Id := N + 683;
- Name_Linker : constant Name_Id := N + 684;
- Name_Linker_Executable_Option : constant Name_Id := N + 685;
- Name_Linker_Lib_Dir_Option : constant Name_Id := N + 686;
- Name_Linker_Lib_Name_Option : constant Name_Id := N + 687;
- Name_Local_Config_File : constant Name_Id := N + 688;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 689;
- Name_Locally_Removed_Files : constant Name_Id := N + 690;
- Name_Mapping_File_Switches : constant Name_Id := N + 691;
- Name_Mapping_Spec_Suffix : constant Name_Id := N + 692;
- Name_Mapping_Body_Suffix : constant Name_Id := N + 693;
- Name_Metrics : constant Name_Id := N + 694;
- Name_Naming : constant Name_Id := N + 695;
- Name_Objects_Path : constant Name_Id := N + 696;
- Name_Objects_Path_File : constant Name_Id := N + 697;
- Name_Object_Dir : constant Name_Id := N + 698;
- Name_Pic_Option : constant Name_Id := N + 699;
- Name_Pretty_Printer : constant Name_Id := N + 700;
- Name_Prefix : constant Name_Id := N + 701;
- Name_Project : constant Name_Id := N + 702;
- Name_Roots : constant Name_Id := N + 703;
- Name_Required_Switches : constant Name_Id := N + 704;
- Name_Run_Path_Option : constant Name_Id := N + 705;
- Name_Runtime_Project : constant Name_Id := N + 706;
- Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 707;
- Name_Shared_Library_Prefix : constant Name_Id := N + 708;
- Name_Shared_Library_Suffix : constant Name_Id := N + 709;
- Name_Separate_Suffix : constant Name_Id := N + 710;
- Name_Source_Dirs : constant Name_Id := N + 711;
- Name_Source_Files : constant Name_Id := N + 712;
- Name_Source_List_File : constant Name_Id := N + 713;
- Name_Spec : constant Name_Id := N + 714;
- Name_Spec_Suffix : constant Name_Id := N + 715;
- Name_Specification : constant Name_Id := N + 716;
- Name_Specification_Exceptions : constant Name_Id := N + 717;
- Name_Specification_Suffix : constant Name_Id := N + 718;
- Name_Stack : constant Name_Id := N + 719;
- Name_Switches : constant Name_Id := N + 720;
- Name_Symbolic_Link_Supported : constant Name_Id := N + 721;
- Name_Sync : constant Name_Id := N + 722;
- Name_Synchronize : constant Name_Id := N + 723;
- Name_Toolchain_Description : constant Name_Id := N + 724;
- Name_Toolchain_Version : constant Name_Id := N + 725;
- Name_Runtime_Library_Dir : constant Name_Id := N + 726;
+ Name_Ada_Roots : constant Name_Id := N + 632;
+ Name_Aggregate : constant Name_Id := N + 633;
+ Name_Archive_Builder : constant Name_Id := N + 634;
+ Name_Archive_Builder_Append_Option : constant Name_Id := N + 635;
+ Name_Archive_Indexer : constant Name_Id := N + 636;
+ Name_Archive_Suffix : constant Name_Id := N + 637;
+ Name_Binder : constant Name_Id := N + 638;
+ Name_Binder_Prefix : constant Name_Id := N + 639;
+ Name_Body_Suffix : constant Name_Id := N + 640;
+ Name_Builder : constant Name_Id := N + 641;
+ Name_Builder_Switches : constant Name_Id := N + 642;
+ Name_Compiler : constant Name_Id := N + 643;
+ Name_Compiler_Kind : constant Name_Id := N + 644;
+ Name_Config_Body_File_Name : constant Name_Id := N + 645;
+ Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 646;
+ Name_Config_File_Switches : constant Name_Id := N + 647;
+ Name_Config_File_Unique : constant Name_Id := N + 648;
+ Name_Config_Spec_File_Name : constant Name_Id := N + 649;
+ Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 650;
+ Name_Configuration : constant Name_Id := N + 651;
+ Name_Cross_Reference : constant Name_Id := N + 652;
+ Name_Default_Language : constant Name_Id := N + 653;
+ Name_Default_Switches : constant Name_Id := N + 654;
+ Name_Dependency_Driver : constant Name_Id := N + 655;
+ Name_Dependency_File_Kind : constant Name_Id := N + 656;
+ Name_Dependency_Switches : constant Name_Id := N + 657;
+ Name_Driver : constant Name_Id := N + 658;
+ Name_Excluded_Source_Dirs : constant Name_Id := N + 659;
+ Name_Excluded_Source_Files : constant Name_Id := N + 660;
+ Name_Exec_Dir : constant Name_Id := N + 661;
+ Name_Executable : constant Name_Id := N + 662;
+ Name_Executable_Suffix : constant Name_Id := N + 663;
+ Name_Extends : constant Name_Id := N + 664;
+ Name_Externally_Built : constant Name_Id := N + 665;
+ Name_Finder : constant Name_Id := N + 666;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 667;
+ Name_Global_Config_File : constant Name_Id := N + 668;
+ Name_Gnatls : constant Name_Id := N + 669;
+ Name_Gnatstub : constant Name_Id := N + 670;
+ Name_Implementation : constant Name_Id := N + 671;
+ Name_Implementation_Exceptions : constant Name_Id := N + 672;
+ Name_Implementation_Suffix : constant Name_Id := N + 673;
+ Name_Include_Switches : constant Name_Id := N + 674;
+ Name_Include_Path : constant Name_Id := N + 675;
+ Name_Include_Path_File : constant Name_Id := N + 676;
+ Name_Inherit_Source_Path : constant Name_Id := N + 677;
+ Name_Language_Kind : constant Name_Id := N + 678;
+ Name_Language_Processing : constant Name_Id := N + 679;
+ Name_Languages : constant Name_Id := N + 680;
+ Name_Library : constant Name_Id := N + 681;
+ Name_Library_Ali_Dir : constant Name_Id := N + 682;
+ Name_Library_Auto_Init : constant Name_Id := N + 683;
+ Name_Library_Auto_Init_Supported : constant Name_Id := N + 684;
+ Name_Library_Builder : constant Name_Id := N + 685;
+ Name_Library_Dir : constant Name_Id := N + 686;
+ Name_Library_GCC : constant Name_Id := N + 687;
+ Name_Library_Interface : constant Name_Id := N + 688;
+ Name_Library_Kind : constant Name_Id := N + 689;
+ Name_Library_Name : constant Name_Id := N + 690;
+ Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 691;
+ Name_Library_Options : constant Name_Id := N + 692;
+ Name_Library_Partial_Linker : constant Name_Id := N + 693;
+ Name_Library_Reference_Symbol_File : constant Name_Id := N + 694;
+ Name_Library_Src_Dir : constant Name_Id := N + 695;
+ Name_Library_Support : constant Name_Id := N + 696;
+ Name_Library_Symbol_File : constant Name_Id := N + 697;
+ Name_Library_Symbol_Policy : constant Name_Id := N + 698;
+ Name_Library_Version : constant Name_Id := N + 699;
+ Name_Library_Version_Switches : constant Name_Id := N + 700;
+ Name_Linker : constant Name_Id := N + 701;
+ Name_Linker_Executable_Option : constant Name_Id := N + 702;
+ Name_Linker_Lib_Dir_Option : constant Name_Id := N + 703;
+ Name_Linker_Lib_Name_Option : constant Name_Id := N + 704;
+ Name_Local_Config_File : constant Name_Id := N + 705;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 706;
+ Name_Locally_Removed_Files : constant Name_Id := N + 707;
+ Name_Mapping_File_Switches : constant Name_Id := N + 708;
+ Name_Mapping_Spec_Suffix : constant Name_Id := N + 709;
+ Name_Mapping_Body_Suffix : constant Name_Id := N + 710;
+ Name_Metrics : constant Name_Id := N + 711;
+ Name_Naming : constant Name_Id := N + 712;
+ Name_Objects_Path : constant Name_Id := N + 713;
+ Name_Objects_Path_File : constant Name_Id := N + 714;
+ Name_Object_Dir : constant Name_Id := N + 715;
+ Name_Pic_Option : constant Name_Id := N + 716;
+ Name_Pretty_Printer : constant Name_Id := N + 717;
+ Name_Prefix : constant Name_Id := N + 718;
+ Name_Project : constant Name_Id := N + 719;
+ Name_Roots : constant Name_Id := N + 720;
+ Name_Required_Switches : constant Name_Id := N + 721;
+ Name_Run_Path_Option : constant Name_Id := N + 722;
+ Name_Runtime_Project : constant Name_Id := N + 723;
+ Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 724;
+ Name_Shared_Library_Prefix : constant Name_Id := N + 725;
+ Name_Shared_Library_Suffix : constant Name_Id := N + 726;
+ Name_Separate_Suffix : constant Name_Id := N + 727;
+ Name_Source_Dirs : constant Name_Id := N + 728;
+ Name_Source_Files : constant Name_Id := N + 729;
+ Name_Source_List_File : constant Name_Id := N + 730;
+ Name_Spec : constant Name_Id := N + 731;
+ Name_Spec_Suffix : constant Name_Id := N + 732;
+ Name_Specification : constant Name_Id := N + 733;
+ Name_Specification_Exceptions : constant Name_Id := N + 734;
+ Name_Specification_Suffix : constant Name_Id := N + 735;
+ Name_Stack : constant Name_Id := N + 736;
+ Name_Switches : constant Name_Id := N + 737;
+ Name_Symbolic_Link_Supported : constant Name_Id := N + 738;
+ Name_Sync : constant Name_Id := N + 739;
+ Name_Synchronize : constant Name_Id := N + 740;
+ Name_Toolchain_Description : constant Name_Id := N + 741;
+ Name_Toolchain_Version : constant Name_Id := N + 742;
+ Name_Runtime_Library_Dir : constant Name_Id := N + 743;
-- Other miscellaneous names used in front end
- Name_Unaligned_Valid : constant Name_Id := N + 727;
+ Name_Unaligned_Valid : constant Name_Id := N + 744;
-- Ada 2005 reserved words
- First_2005_Reserved_Word : constant Name_Id := N + 728;
- Name_Interface : constant Name_Id := N + 728;
- Name_Overriding : constant Name_Id := N + 729;
- Name_Synchronized : constant Name_Id := N + 730;
- Last_2005_Reserved_Word : constant Name_Id := N + 730;
+ First_2005_Reserved_Word : constant Name_Id := N + 745;
+ Name_Interface : constant Name_Id := N + 745;
+ Name_Overriding : constant Name_Id := N + 746;
+ Name_Synchronized : constant Name_Id := N + 747;
+ Last_2005_Reserved_Word : constant Name_Id := N + 747;
subtype Ada_2005_Reserved_Words is
Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 730;
+ Last_Predefined_Name : constant Name_Id := N + 747;
---------------------------------------
-- Subtypes Defining Name Categories --
Attribute_Emax,
Attribute_Enabled,
Attribute_Enum_Rep,
+ Attribute_Enum_Val,
Attribute_Epsilon,
Attribute_Exponent,
Attribute_External_Tag,
Attribute_Fore,
Attribute_Has_Access_Values,
Attribute_Has_Discriminants,
+ Attribute_Has_Tagged_Values,
Attribute_Identity,
Attribute_Img,
Attribute_Integer_Value,
+ Attribute_Invalid_Value,
Attribute_Large,
Attribute_Last,
Attribute_Last_Bit,
Attribute_Priority,
Attribute_Range,
Attribute_Range_Length,
+ Attribute_Result,
Attribute_Round,
Attribute_Safe_Emax,
Attribute_Safe_First,
-- Configuration pragmas
+ -- Note: This list is in the GNAT users guide, so be sure that if any
+ -- additions or deletions are made to the following list, they are
+ -- properly reflected in the users guide.
+
Pragma_Ada_83,
Pragma_Ada_95,
Pragma_Ada_05,
Pragma_Assertion_Policy,
Pragma_C_Pass_By_Copy,
Pragma_Check_Name,
+ Pragma_Check_Policy,
Pragma_Compile_Time_Error,
Pragma_Compile_Time_Warning,
Pragma_Compiler_Unit,
Pragma_No_Strict_Aliasing,
Pragma_Normalize_Scalars,
Pragma_Optimize_Alignment,
- Pragma_Polling,
Pragma_Persistent_BSS,
+ Pragma_Polling,
Pragma_Priority_Specific_Dispatching,
Pragma_Profile,
Pragma_Profile_Warnings,
Pragma_Atomic,
Pragma_Atomic_Components,
Pragma_Attach_Handler,
+ Pragma_Check,
Pragma_CIL_Constructor,
Pragma_Comment,
Pragma_Common_Object,
Pragma_Pack,
Pragma_Page,
Pragma_Passive,
+ Pragma_Postcondition,
+ Pragma_Precondition,
Pragma_Preelaborable_Initialization,
Pragma_Preelaborate,
Pragma_Preelaborate_05,
Pragma_Pure,
Pragma_Pure_05,
Pragma_Pure_Function,
+ Pragma_Relative_Deadline,
Pragma_Remote_Call_Interface,
Pragma_Remote_Types,
Pragma_Share_Generic,
* *
* C Header File *
* *
- * Copyright (C) 1992-2007, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2008, 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- *
#define Attr_Emax 26
#define Attr_Enabled 27
#define Attr_Enum_Rep 28
-#define Attr_Epsilon 29
-#define Attr_Exponent 30
-#define Attr_External_Tag 31
-#define Attr_Fast_Math 32
-#define Attr_First 33
-#define Attr_First_Bit 34
-#define Attr_Fixed_Value 35
-#define Attr_Fore 36
-#define Attr_Has_Access_Values 37
-#define Attr_Has_Discriminants 38
-#define Attr_Identity 39
-#define Attr_Img 40
-#define Attr_Integer_Value 41
-#define Attr_Large 42
-#define Attr_Last 43
-#define Attr_Last_Bit 44
-#define Attr_Leading_Part 45
-#define Attr_Length 46
-#define Attr_Machine_Emax 47
-#define Attr_Machine_Emin 48
-#define Attr_Machine_Mantissa 49
-#define Attr_Machine_Overflows 50
-#define Attr_Machine_Radix 51
-#define Attr_Machine_Rounding 52
-#define Attr_Machine_Rounds 53
-#define Attr_Machine_Size 54
-#define Attr_Mantissa 55
-#define Attr_Max_Size_In_Storage_Elements 56
-#define Attr_Maximum_Alignment 57
-#define Attr_Mechanism_Code 58
-#define Attr_Mod 59
-#define Attr_Model_Emin 60
-#define Attr_Model_Epsilon 61
-#define Attr_Model_Mantissa 62
-#define Attr_Model_Small 63
-#define Attr_Modulus 64
-#define Attr_Null_Parameter 65
-#define Attr_Object_Size 66
-#define Attr_Old 67
-#define Attr_Partition_ID 68
-#define Attr_Passed_By_Reference 69
-#define Attr_Pool_Address 70
-#define Attr_Pos 71
-#define Attr_Position 72
-#define Attr_Priority 73
-#define Attr_Range 74
-#define Attr_Range_Length 75
-#define Attr_Round 76
-#define Attr_Safe_Emax 77
-#define Attr_Safe_First 78
-#define Attr_Safe_Large 79
-#define Attr_Safe_Last 80
-#define Attr_Safe_Small 81
-#define Attr_Scale 82
-#define Attr_Scaling 83
-#define Attr_Signed_Zeros 84
-#define Attr_Size 85
-#define Attr_Small 86
-#define Attr_Storage_Size 87
-#define Attr_Storage_Unit 88
-#define Attr_Stream_Size 89
-#define Attr_Tag 90
-#define Attr_Target_Name 91
-#define Attr_Terminated 92
-#define Attr_To_Address 93
-#define Attr_Type_Class 94
-#define Attr_UET_Address 95
-#define Attr_Unbiased_Rounding 96
-#define Attr_Unchecked_Access 97
-#define Attr_Unconstrained_Array 98
-#define Attr_Universal_Literal_String 99
-#define Attr_Unrestricted_Access 100
-#define Attr_VADS_Size 101
-#define Attr_Val 102
-#define Attr_Valid 103
-#define Attr_Value_Size 104
-#define Attr_Version 105
-#define Attr_Wchar_T_Size 106
-#define Attr_Wide_Wide_Width 107
-#define Attr_Wide_Width 108
-#define Attr_Width 109
-#define Attr_Word_Size 110
-#define Attr_Adjacent 111
-#define Attr_Ceiling 112
-#define Attr_Copy_Sign 113
-#define Attr_Floor 114
-#define Attr_Fraction 115
-#define Attr_Image 116
-#define Attr_Input 117
-#define Attr_Machine 118
-#define Attr_Max 119
-#define Attr_Min 120
-#define Attr_Model 121
-#define Attr_Pred 122
-#define Attr_Remainder 123
-#define Attr_Rounding 124
-#define Attr_Succ 125
-#define Attr_Truncation 126
-#define Attr_Value 127
-#define Attr_Wide_Image 128
-#define Attr_Wide_Wide_Image 129
-#define Attr_Wide_Value 130
-#define Attr_Wide_Wide_Value 131
-#define Attr_Output 132
-#define Attr_Read 133
-#define Attr_Write 134
-#define Attr_Elab_Body 135
-#define Attr_Elab_Spec 136
-#define Attr_Storage_Pool 137
-#define Attr_Base 138
-#define Attr_Class 139
-#define Attr_Stub_Type 140
+#define Attr_Enum_Val 29
+#define Attr_Epsilon 30
+#define Attr_Exponent 31
+#define Attr_External_Tag 32
+#define Attr_Fast_Math 33
+#define Attr_First 34
+#define Attr_First_Bit 35
+#define Attr_Fixed_Value 36
+#define Attr_Fore 37
+#define Attr_Has_Access_Values 38
+#define Attr_Has_Discriminants 39
+#define Attr_Has_Tagged_Values 40
+#define Attr_Identity 41
+#define Attr_Img 42
+#define Attr_Integer_Value 43
+#define Attr_Invalid_Value 44
+#define Attr_Large 45
+#define Attr_Last 46
+#define Attr_Last_Bit 47
+#define Attr_Leading_Part 48
+#define Attr_Length 49
+#define Attr_Machine_Emax 50
+#define Attr_Machine_Emin 51
+#define Attr_Machine_Mantissa 52
+#define Attr_Machine_Overflows 53
+#define Attr_Machine_Radix 54
+#define Attr_Machine_Rounding 55
+#define Attr_Machine_Rounds 56
+#define Attr_Machine_Size 57
+#define Attr_Mantissa 58
+#define Attr_Max_Size_In_Storage_Elements 59
+#define Attr_Maximum_Alignment 60
+#define Attr_Mechanism_Code 61
+#define Attr_Mod 62
+#define Attr_Model_Emin 63
+#define Attr_Model_Epsilon 64
+#define Attr_Model_Mantissa 65
+#define Attr_Model_Small 66
+#define Attr_Modulus 67
+#define Attr_Null_Parameter 68
+#define Attr_Object_Size 69
+#define Attr_Old 70
+#define Attr_Partition_ID 71
+#define Attr_Passed_By_Reference 72
+#define Attr_Pool_Address 73
+#define Attr_Pos 74
+#define Attr_Position 75
+#define Attr_Priority 76
+#define Attr_Range 77
+#define Attr_Range_Length 78
+#define Attr_Result 79
+#define Attr_Round 80
+#define Attr_Safe_Emax 81
+#define Attr_Safe_First 82
+#define Attr_Safe_Large 83
+#define Attr_Safe_Last 84
+#define Attr_Safe_Small 85
+#define Attr_Scale 86
+#define Attr_Scaling 87
+#define Attr_Signed_Zeros 88
+#define Attr_Size 89
+#define Attr_Small 90
+#define Attr_Storage_Size 91
+#define Attr_Storage_Unit 92
+#define Attr_Stream_Size 93
+#define Attr_Tag 94
+#define Attr_Target_Name 95
+#define Attr_Terminated 96
+#define Attr_To_Address 97
+#define Attr_Type_Class 98
+#define Attr_UET_Address 99
+#define Attr_Unbiased_Rounding 100
+#define Attr_Unchecked_Access 101
+#define Attr_Unconstrained_Array 102
+#define Attr_Universal_Literal_String 103
+#define Attr_Unrestricted_Access 104
+#define Attr_VADS_Size 105
+#define Attr_Val 106
+#define Attr_Valid 107
+#define Attr_Value_Size 108
+#define Attr_Version 109
+#define Attr_Wchar_T_Size 110
+#define Attr_Wide_Wide_Width 111
+#define Attr_Wide_Width 112
+#define Attr_Width 113
+#define Attr_Word_Size 114
+#define Attr_Adjacent 115
+#define Attr_Ceiling 116
+#define Attr_Copy_Sign 117
+#define Attr_Floor 118
+#define Attr_Fraction 119
+#define Attr_Image 120
+#define Attr_Input 121
+#define Attr_Machine 122
+#define Attr_Max 123
+#define Attr_Min 124
+#define Attr_Model 125
+#define Attr_Pred 126
+#define Attr_Remainder 127
+#define Attr_Rounding 128
+#define Attr_Succ 129
+#define Attr_Truncation 130
+#define Attr_Value 131
+#define Attr_Wide_Image 132
+#define Attr_Wide_Wide_Image 133
+#define Attr_Wide_Value 134
+#define Attr_Wide_Wide_Value 135
+#define Attr_Output 136
+#define Attr_Read 137
+#define Attr_Write 138
+#define Attr_Elab_Body 139
+#define Attr_Elab_Spec 140
+#define Attr_Storage_Pool 141
+#define Attr_Base 142
+#define Attr_Class 143
+#define Attr_Stub_Type 144
/* Define the numeric values for the conventions. */
#define Pragma_Assertion_Policy 4
#define Pragma_C_Pass_By_Copy 5
#define Pragma_Check_Name 6
-#define Pragma_Compile_Time_Error 7
-#define Pragma_Compile_Time_Warning 8
-#define Pragma_Compiler_Unit 9
-#define Pragma_Component_Alignment 10
-#define Pragma_Convention_Identifier 11
-#define Pragma_Debug_Policy 12
-#define Pragma_Detect_Blocking 13
-#define Pragma_Discard_Names 14
-#define Pragma_Elaboration_Checks 15
-#define Pragma_Eliminate 16
-#define Pragma_Extend_System 17
-#define Pragma_Extensions_Allowed 18
-#define Pragma_External_Name_Casing 19
-#define Pragma_Favor_Top_Level 20
-#define Pragma_Float_Representation 21
-#define Pragma_Implicit_Packing 22
-#define Pragma_Initialize_Scalars 23
-#define Pragma_Interrupt_State 24
-#define Pragma_License 25
-#define Pragma_Locking_Policy 26
-#define Pragma_Long_Float 27
-#define Pragma_No_Run_Time 28
-#define Pragma_No_Strict_Aliasing 29
-#define Pragma_Normalize_Scalars 30
-#define Pragma_Optimize_Alignment 31
-#define Pragma_Polling 32
-#define Pragma_Persistent_BSS 33
-#define Pragma_Priority_Specific_Dispatching 34
-#define Pragma_Profile 35
-#define Pragma_Profile_Warnings 36
-#define Pragma_Propagate_Exceptions 37
-#define Pragma_Queuing_Policy 38
-#define Pragma_Ravenscar 39
-#define Pragma_Restricted_Run_Time 40
-#define Pragma_Restrictions 41
-#define Pragma_Restriction_Warnings 42
-#define Pragma_Reviewable 43
-#define Pragma_Source_File_Name 44
-#define Pragma_Source_File_Name_Project 45
-#define Pragma_Style_Checks 46
-#define Pragma_Suppress 47
-#define Pragma_Suppress_Exception_Locations 48
-#define Pragma_Task_Dispatching_Policy 49
-#define Pragma_Universal_Data 50
-#define Pragma_Unsuppress 51
-#define Pragma_Use_VADS_Size 52
-#define Pragma_Validity_Checks 53
-#define Pragma_Warnings 54
-#define Pragma_Wide_Character_Encoding 55
-#define Pragma_Abort_Defer 56
-#define Pragma_All_Calls_Remote 57
-#define Pragma_Annotate 58
-#define Pragma_Assert 59
-#define Pragma_Asynchronous 60
-#define Pragma_Atomic 61
-#define Pragma_Atomic_Components 62
-#define Pragma_Attach_Handler 63
-#define Pragma_CIL_Constructor 64
-#define Pragma_Comment 65
-#define Pragma_Common_Object 66
-#define Pragma_Complete_Representation 67
-#define Pragma_Complex_Representation 68
-#define Pragma_Controlled 69
-#define Pragma_Convention 70
-#define Pragma_CPP_Class 71
-#define Pragma_CPP_Constructor 72
-#define Pragma_CPP_Virtual 73
-#define Pragma_CPP_Vtable 74
-#define Pragma_Debug 75
-#define Pragma_Elaborate 76
-#define Pragma_Elaborate_All 77
-#define Pragma_Elaborate_Body 78
-#define Pragma_Export 79
-#define Pragma_Export_Exception 80
-#define Pragma_Export_Function 81
-#define Pragma_Export_Object 82
-#define Pragma_Export_Procedure 83
-#define Pragma_Export_Value 84
-#define Pragma_Export_Valued_Procedure 85
-#define Pragma_External 86
-#define Pragma_Finalize_Storage_Only 87
-#define Pragma_Ident 88
-#define Pragma_Implemented_By_Entry 89
-#define Pragma_Import 90
-#define Pragma_Import_Exception 91
-#define Pragma_Import_Function 92
-#define Pragma_Import_Object 93
-#define Pragma_Import_Procedure 94
-#define Pragma_Import_Valued_Procedure 95
-#define Pragma_Inline 96
-#define Pragma_Inline_Always 97
-#define Pragma_Inline_Generic 98
-#define Pragma_Inspection_Point 99
-#define Pragma_Interface_Name 100
-#define Pragma_Interrupt_Handler 101
-#define Pragma_Interrupt_Priority 102
-#define Pragma_Java_Constructor 103
-#define Pragma_Java_Interface 104
-#define Pragma_Keep_Names 105
-#define Pragma_Link_With 106
-#define Pragma_Linker_Alias 107
-#define Pragma_Linker_Constructor 108
-#define Pragma_Linker_Destructor 109
-#define Pragma_Linker_Options 110
-#define Pragma_Linker_Section 111
-#define Pragma_List 112
-#define Pragma_Machine_Attribute 113
-#define Pragma_Main 114
-#define Pragma_Main_Storage 115
-#define Pragma_Memory_Size 116
-#define Pragma_No_Body 117
-#define Pragma_No_Return 118
-#define Pragma_Obsolescent 119
-#define Pragma_Optimize 120
-#define Pragma_Pack 121
-#define Pragma_Page 122
-#define Pragma_Passive 123
-#define Pragma_Preelaborable_Initialization 124
-#define Pragma_Preelaborate 125
-#define Pragma_Preelaborate_05 126
-#define Pragma_Psect_Object 127
-#define Pragma_Pure 128
-#define Pragma_Pure_05 129
-#define Pragma_Pure_Function 130
-#define Pragma_Remote_Call_Interface 131
-#define Pragma_Remote_Types 132
-#define Pragma_Share_Generic 133
-#define Pragma_Shared 134
-#define Pragma_Shared_Passive 135
-#define Pragma_Source_Reference 136
-#define Pragma_Static_Elaboration_Desired 137
-#define Pragma_Stream_Convert 138
-#define Pragma_Subtitle 139
-#define Pragma_Suppress_All 140
-#define Pragma_Suppress_Debug_Info 141
-#define Pragma_Suppress_Initialization 142
-#define Pragma_System_Name 143
-#define Pragma_Task_Info 144
-#define Pragma_Task_Name 145
-#define Pragma_Task_Storage 146
-#define Pragma_Time_Slice 147
-#define Pragma_Title 148
-#define Pragma_Unchecked_Union 149
-#define Pragma_Unimplemented_Unit 150
-#define Pragma_Universal_Aliasing 151
-#define Pragma_Unmodified 152
-#define Pragma_Unreferenced 153
-#define Pragma_Unreferenced_Objects 154
-#define Pragma_Unreserve_All_Interrupts 155
-#define Pragma_Volatile 156
-#define Pragma_Volatile_Components 157
-#define Pragma_Weak_External 158
-#define Pragma_AST_Entry 159
-#define Pragma_Fast_Math 160
-#define Pragma_Interface 161
-#define Pragma_Priority 162
-#define Pragma_Storage_Size 163
-#define Pragma_Storage_Unit 164
+#define Pragma_Check_Policy 7
+#define Pragma_Compile_Time_Error 8
+#define Pragma_Compile_Time_Warning 9
+#define Pragma_Compiler_Unit 10
+#define Pragma_Component_Alignment 11
+#define Pragma_Convention_Identifier 12
+#define Pragma_Debug_Policy 13
+#define Pragma_Detect_Blocking 14
+#define Pragma_Discard_Names 15
+#define Pragma_Elaboration_Checks 16
+#define Pragma_Eliminate 17
+#define Pragma_Extend_System 18
+#define Pragma_Extensions_Allowed 19
+#define Pragma_External_Name_Casing 20
+#define Pragma_Favor_Top_Level 21
+#define Pragma_Float_Representation 22
+#define Pragma_Implicit_Packing 23
+#define Pragma_Initialize_Scalars 24
+#define Pragma_Interrupt_State 25
+#define Pragma_License 26
+#define Pragma_Locking_Policy 27
+#define Pragma_Long_Float 28
+#define Pragma_No_Run_Time 29
+#define Pragma_No_Strict_Aliasing 30
+#define Pragma_Normalize_Scalars 31
+#define Pragma_Optimize_Alignment 32
+#define Pragma_Polling 33
+#define Pragma_Persistent_BSS 34
+#define Pragma_Priority_Specific_Dispatching 35
+#define Pragma_Profile 36
+#define Pragma_Profile_Warnings 37
+#define Pragma_Propagate_Exceptions 38
+#define Pragma_Queuing_Policy 39
+#define Pragma_Ravenscar 40
+#define Pragma_Restricted_Run_Time 41
+#define Pragma_Restrictions 42
+#define Pragma_Restriction_Warnings 43
+#define Pragma_Reviewable 44
+#define Pragma_Source_File_Name 45
+#define Pragma_Source_File_Name_Project 46
+#define Pragma_Style_Checks 47
+#define Pragma_Suppress 48
+#define Pragma_Suppress_Exception_Locations 49
+#define Pragma_Task_Dispatching_Policy 50
+#define Pragma_Universal_Data 51
+#define Pragma_Unsuppress 52
+#define Pragma_Use_VADS_Size 53
+#define Pragma_Validity_Checks 54
+#define Pragma_Warnings 55
+#define Pragma_Wide_Character_Encoding 56
+#define Pragma_Abort_Defer 57
+#define Pragma_All_Calls_Remote 58
+#define Pragma_Annotate 59
+#define Pragma_Assert 60
+#define Pragma_Asynchronous 61
+#define Pragma_Atomic 62
+#define Pragma_Atomic_Components 63
+#define Pragma_Attach_Handler 64
+#define Pragma_Check 65
+#define Pragma_CIL_Constructor 66
+#define Pragma_Comment 67
+#define Pragma_Common_Object 68
+#define Pragma_Complete_Representation 69
+#define Pragma_Complex_Representation 70
+#define Pragma_Controlled 71
+#define Pragma_Convention 72
+#define Pragma_CPP_Class 73
+#define Pragma_CPP_Constructor 74
+#define Pragma_CPP_Virtual 75
+#define Pragma_CPP_Vtable 76
+#define Pragma_Debug 77
+#define Pragma_Elaborate 78
+#define Pragma_Elaborate_All 79
+#define Pragma_Elaborate_Body 80
+#define Pragma_Export 81
+#define Pragma_Export_Exception 82
+#define Pragma_Export_Function 83
+#define Pragma_Export_Object 84
+#define Pragma_Export_Procedure 85
+#define Pragma_Export_Value 86
+#define Pragma_Export_Valued_Procedure 87
+#define Pragma_External 88
+#define Pragma_Finalize_Storage_Only 89
+#define Pragma_Ident 90
+#define Pragma_Implemented_By_Entry 91
+#define Pragma_Import 92
+#define Pragma_Import_Exception 93
+#define Pragma_Import_Function 94
+#define Pragma_Import_Object 95
+#define Pragma_Import_Procedure 96
+#define Pragma_Import_Valued_Procedure 97
+#define Pragma_Inline 98
+#define Pragma_Inline_Always 99
+#define Pragma_Inline_Generic 100
+#define Pragma_Inspection_Point 101
+#define Pragma_Interface_Name 102
+#define Pragma_Interrupt_Handler 103
+#define Pragma_Interrupt_Priority 104
+#define Pragma_Java_Constructor 105
+#define Pragma_Java_Interface 106
+#define Pragma_Keep_Names 107
+#define Pragma_Link_With 108
+#define Pragma_Linker_Alias 109
+#define Pragma_Linker_Constructor 110
+#define Pragma_Linker_Destructor 111
+#define Pragma_Linker_Options 112
+#define Pragma_Linker_Section 113
+#define Pragma_List 114
+#define Pragma_Machine_Attribute 115
+#define Pragma_Main 116
+#define Pragma_Main_Storage 117
+#define Pragma_Memory_Size 118
+#define Pragma_No_Body 119
+#define Pragma_No_Return 120
+#define Pragma_Obsolescent 121
+#define Pragma_Optimize 122
+#define Pragma_Pack 123
+#define Pragma_Page 124
+#define Pragma_Passive 125
+#define Pragma_Postcondition 126
+#define Pragma_Precondition 127
+#define Pragma_Preelaborable_Initialization 128
+#define Pragma_Preelaborate 129
+#define Pragma_Preelaborate_05 130
+#define Pragma_Psect_Object 131
+#define Pragma_Pure 132
+#define Pragma_Pure_05 133
+#define Pragma_Pure_Function 134
+#define Pragma_Relative_Deadline 135
+#define Pragma_Remote_Call_Interface 136
+#define Pragma_Remote_Types 137
+#define Pragma_Share_Generic 138
+#define Pragma_Shared 139
+#define Pragma_Shared_Passive 140
+#define Pragma_Source_Reference 141
+#define Pragma_Static_Elaboration_Desired 142
+#define Pragma_Stream_Convert 143
+#define Pragma_Subtitle 144
+#define Pragma_Suppress_All 145
+#define Pragma_Suppress_Debug_Info 146
+#define Pragma_Suppress_Initialization 147
+#define Pragma_System_Name 148
+#define Pragma_Task_Info 149
+#define Pragma_Task_Name 150
+#define Pragma_Task_Storage 151
+#define Pragma_Time_Slice 152
+#define Pragma_Title 153
+#define Pragma_Unchecked_Union 154
+#define Pragma_Unimplemented_Unit 155
+#define Pragma_Universal_Aliasing 156
+#define Pragma_Unmodified 157
+#define Pragma_Unreferenced 158
+#define Pragma_Unreferenced_Objects 159
+#define Pragma_Unreserve_All_Interrupts 160
+#define Pragma_Volatile 161
+#define Pragma_Volatile_Components 162
+#define Pragma_Weak_External 163
+#define Pragma_AST_Entry 164
+#define Pragma_Fast_Math 165
+#define Pragma_Interface 166
+#define Pragma_Priority 167
+#define Pragma_Storage_Size 168
+#define Pragma_Storage_Unit 169
/* End of snames.h (C version of Snames package spec) */
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
with Opt;
with Osint.C;
with Repinfo;
+with Sem_Aux;
with Sinput;
with Stand;
with Stringt;
with Uintp;
with Urealp;
+with Tree_In;
+pragma Warnings (Off, Tree_In);
+-- We do not use Tree_In in the compiler, but it is small, and worth including
+-- so that we get the proper license check for Tree_In when the compiler is
+-- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS.
+
procedure Tree_Gen is
begin
if Opt.Tree_Output then
Lib.Tree_Write;
Namet.Tree_Write;
Nlists.Tree_Write;
+ Sem_Aux.Tree_Write;
Sinput.Tree_Write;
Stand.Tree_Write;
Stringt.Tree_Write;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
with Nlists;
with Opt;
with Repinfo;
+with Sem_Aux;
with Sinput;
with Stand;
with Stringt;
Lib.Tree_Read;
Namet.Tree_Read;
Nlists.Tree_Read;
+ Sem_Aux.Tree_Read;
Sinput.Tree_Read;
Stand.Tree_Read;
Stringt.Tree_Read;
projects / platform / upstream / gcc.git / commitdiff