From 4660e715aa628a0071e76853fda39cf8057c2c4e Mon Sep 17 00:00:00 2001
From: charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Tue, 15 Mar 2005 15:54:14 +0000
Subject: 2005-03-08 Javier Miranda <miranda@adacore.com> Robert
Dewar <dewar@adacore.com> Thomas Quinot <quinot@adacore.com>
Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* atree.ads, atree.adb: Add support for Elist24 field
* atree.h: Fix wrong definition of Field27
Add support for Elist16 field
Add support for Elist24 field
* einfo.ads, einfo.adb (Abstract_Interfaces,
Set_Abstract_Interfaces): New subprograms.
(Abstract_Interface_Alias, Set_Abstract_Interface_Alias): New
subprograms.
(Access_Disp_Table, Set_Access_Disp_Table): Modified to handle a list of
entities rather than a single node.
(Is_Interface, Set_Is_Interface): New subprogram
(First_Tag_Component): New syntesized attribute
(Next_Tag_Component): New synthesized attribute
(Write_Entity_Flags): Upgraded to write Is_Interface
(Write_Field24_Name): Upgraded to write Abstract_Interfaces
(Write_Field25_Name): Upgraded to write Abstract_Interface_Alias
(Task_Body_Procedure): New subprogram to read this attribute.
(Set_Task_Body_Procedure): New subprogram to set this attribute.
(Has_Controlled_Component): Now applies to all entities.
This is only a documentation change, since it always worked to apply
this to other than composite types (yielding false), but now this is
official.
Update documentation on Must_Be_Byte_Aligned for new spec
* tbuild.adb, exp_dist.adb, exp_disp.adb, exp_ch3.ads, exp_ch3.adb,
exp_attr.adb, exp_aggr.adb, exp_ch4.adb, exp_ch5.adb: Upgrade all the
uses of the Access_Disp_Table attribute to reference the first dispatch
table associated with a tagged type. As
part of the implementation of abstract interface types,
Access_Disp_Table has been redefined to contain a list of dispatch
tables (rather than a single dispatch table).
Similarly, upgrade all the references to Tag_Component by the
new attribute First_Tag_Component.
(Find_Inherited_TSS): Moved to exp_tss.
Clean up test in Expand_N_Object_Declaration for cases
where we need to do a separate assignment of the initial value.
(Expand_N_Object_Declaration): If the expression in the
declaration of a tagged type is an aggregate, no need to generate an
additional tag assignment.
(Freeze_Type): Now a function that returns True if the N_Freeze_Entity
is to be deleted.
Bit packed array ops are only called if operands are known to be
aligned.
(Component_Equality): When returning an N_Raise_Program_Error statement,
ensure that its Etype is set to Empty to avoid confusing GIGI (which
expects that only expressions have a bona fide type).
(Make_Tag_Ctrl_Assignment): Use Build_Actual_Subtype to correctly
determine the amount of data to be copied.
* par.adb (P_Interface_Type_Definition): New subprogram that parses the
new syntax rule of Ada 2005 interfaces (for AI-251 and AI-345):
INTERFACE_TYPE_DEFINITION ::=
[limited | task | protected | synchronized] interface
[AND interface_list]
* par-ch3.adb (P_Type_Declaration): Modified to give support to
interfaces.
(P_Derived_Type_Def_Or_Private_Ext_Decl): Modified to give support to
interfaces.
(P_Interface_Type_Definition): New subprogram that parses the new
syntax rule of Ada 2005 interfaces
(P_Identifier_Declarations): fix two occurrences of 'RENAMES' in error
messages by the correct RENAMES (quotes removed).
* sem_prag.adb: Upgrade all the references to Tag_Component by the new
attribute First_Tag_Component.
* sinfo.ads, sinfo.adb: Remove OK_For_Stream flag, not used, not needed
(Interface_List, Set_Interface_List): New subprograms.
(Interface_Present, Set_Interface_Present): New subprograms.
(Limited_Present, Set_Limited_Present): Available also in derived
type definition nodes.
(Protected_Present, Set_Protected_Present): Available also in
record type definition and
derived type definition nodes.
(Synchronized_Present, Set_Synchronized_Present): New subprograms.
(Task_Present, Set_Task_Present): New subprogram.
(Task_Body_Procedure): Removed.
(Set_Task_Body_Procedure): Removed.
These subprogram have been removed because the attribute
Task_Body_Procedure has been moved to the corresponding task type
or task subtype entity to leave a field free to store the list
of interfaces implemented by a task (for AI-345)
Add Expression field to N_Raise_Statement node for Ada 2005 AI-361
(Null_Exclusion_Present): Change to Flag11, to avoid conflict with
expression flag Do_Range_Check
(Exception_Junk): Change to Flag7 to accomodate above change
(Box_Present, Default_Name, Specification, Set_Box_Present,
Set_Default_Name, Set_Specification): Expand the expression
"X in N_Formal_Subprogram_Declaration" into the corresponding
two comparisons. Required to use the csinfo tool.
* exp_ch11.adb (Expand_N_Raise_Statement): Deal with case where
"with string" given.
* sem_ch11.adb (Analyze_Raise_Statement): Handle case where string
expression given.
* par-ch11.adb (P_Raise_Statement): Recognize with string expression
in 2005 mode
* exp_ch9.adb (Build_Task_Proc_Specification): Modified to use entity
attribute Task_Body_Procedure rather than the old semantic field that
was available in the task_type_declaration node.
* par-ch12.adb (P_Formal_Type_Definition): Modified to handle formal
interface type definitions.
(P_Formal_Derived_Type_Definition): Modified to handle the list of
interfaces.
* par-ch9.adb (P_Task): Modified to handle the list of interfaces in a
task type declaration.
(P_Protected): Modified to handle the list of interfaces in a
protected type declaration.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@96489 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/ada/einfo.adb | 136 ++++++++++++++++++++++++++++++++++++++++++++++++------
1 file changed, 123 insertions(+), 13 deletions(-)
(limited to 'gcc/ada/einfo.adb')
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 8606bf0958a..900b69a7e2b 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -129,7 +129,7 @@ package body Einfo is
-- String_Literal_Low_Bound Node15
-- Shared_Var_Read_Proc Node15
- -- Access_Disp_Table Node16
+ -- Access_Disp_Table Elist16
-- Cloned_Subtype Node16
-- DTC_Entity Node16
-- Entry_Formal Node16
@@ -210,9 +210,13 @@ package body Einfo is
-- Protected_Operation Node23
-- Obsolescent_Warning Node24
+ -- Task_Body_Procedure Node24
+ -- Abstract_Interfaces Node24
+
+ -- Abstract_Interface_Alias Node25
- -- (unused) Node25
-- (unused) Node26
+
-- (unused) Node27
---------------------------------------------
@@ -428,8 +432,8 @@ package body Einfo is
-- Must_Be_On_Byte_Boundary Flag183
-- Has_Stream_Size_Clause Flag184
-- Is_Ada_2005 Flag185
+ -- Is_Interface Flag186
- -- (unused) Flag186
-- (unused) Flag187
-- (unused) Flag188
-- (unused) Flag189
@@ -494,15 +498,31 @@ package body Einfo is
-- Attribute Access Functions --
--------------------------------
+ function Abstract_Interfaces (Id : E) return L is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ return Elist24 (Id);
+ end Abstract_Interfaces;
+
+ function Abstract_Interface_Alias (Id : E) return E is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+ return Node25 (Id);
+ end Abstract_Interface_Alias;
+
function Accept_Address (Id : E) return L is
begin
return Elist21 (Id);
end Accept_Address;
- function Access_Disp_Table (Id : E) return E is
+ function Access_Disp_Table (Id : E) return L is
begin
pragma Assert (Is_Tagged_Type (Id));
- return Node16 (Implementation_Base_Type (Id));
+ return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Actual_Subtype (Id : E) return E is
@@ -1551,6 +1571,16 @@ package body Einfo is
return Flag11 (Id);
end Is_Inlined;
+ function Is_Interface (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private
+ or else Ekind (Id) = E_Class_Wide_Type);
+ return Flag186 (Id);
+ end Is_Interface;
+
function Is_Instantiated (Id : E) return B is
begin
return Flag126 (Id);
@@ -2207,6 +2237,13 @@ package body Einfo is
return Flag165 (Id);
end Suppress_Style_Checks;
+ function Task_Body_Procedure (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Task_Type
+ or else Ekind (Id) = E_Task_Subtype);
+ return Node24 (Id);
+ end Task_Body_Procedure;
+
function Treat_As_Volatile (Id : E) return B is
begin
return Flag41 (Id);
@@ -2434,15 +2471,31 @@ package body Einfo is
-- Attribute Set Procedures --
------------------------------
+ procedure Set_Abstract_Interfaces (Id : E; V : L) is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ Set_Elist24 (Id, V);
+ end Set_Abstract_Interfaces;
+
+ procedure Set_Abstract_Interface_Alias (Id : E; V : E) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+ Set_Node25 (Id, V);
+ end Set_Abstract_Interface_Alias;
+
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
end Set_Accept_Address;
- procedure Set_Access_Disp_Table (Id : E; V : E) is
+ procedure Set_Access_Disp_Table (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
- Set_Node16 (Id, V);
+ Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Final_Chain (Id : E; V : E) is
@@ -3527,6 +3580,15 @@ package body Einfo is
Set_Flag11 (Id, V);
end Set_Is_Inlined;
+ procedure Set_Is_Interface (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private);
+ Set_Flag186 (Id, V);
+ end Set_Is_Interface;
+
procedure Set_Is_Instantiated (Id : E; V : B := True) is
begin
Set_Flag126 (Id, V);
@@ -4194,6 +4256,13 @@ package body Einfo is
Set_Flag165 (Id, V);
end Set_Suppress_Style_Checks;
+ procedure Set_Task_Body_Procedure (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Task_Type
+ or else Ekind (Id) = E_Task_Subtype);
+ Set_Node24 (Id, V);
+ end Set_Task_Body_Procedure;
+
procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
@@ -6039,11 +6108,11 @@ package body Einfo is
return Kind;
end Subtype_Kind;
- -------------------
- -- Tag_Component --
- -------------------
+ -------------------------
+ -- First_Tag_Component --
+ -------------------------
- function Tag_Component (Id : E) return E is
+ function First_Tag_Component (Id : E) return E is
Comp : Entity_Id;
Typ : Entity_Id := Id;
@@ -6070,7 +6139,34 @@ package body Einfo is
-- No tag component found
return Empty;
- end Tag_Component;
+ end First_Tag_Component;
+
+ ------------------------
+ -- Next_Tag_Component --
+ ------------------------
+
+ function Next_Tag_Component (Id : E) return E is
+ Comp : Entity_Id;
+ Typ : constant Entity_Id := Scope (Id);
+
+ begin
+ pragma Assert (Ekind (Id) = E_Component
+ and then Is_Tagged_Type (Typ));
+
+ Comp := Next_Entity (Id);
+ while Present (Comp) loop
+ if Is_Tag (Comp) then
+ pragma Assert (Chars (Comp) /= Name_uTag);
+ return Comp;
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ -- No tag component found
+
+ return Empty;
+ end Next_Tag_Component;
---------------------
-- Type_High_Bound --
@@ -6311,6 +6407,7 @@ package body Einfo is
W ("Is_Imported", Flag24 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Instantiated", Flag126 (Id));
+ W ("Is_Interface", Flag186 (Id));
W ("Is_Internal", Flag17 (Id));
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
@@ -6939,7 +7036,7 @@ package body Einfo is
E_Procedure =>
Write_Str ("Alias");
- when E_Record_Type =>
+ when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
when E_Entry_Index_Parameter =>
@@ -7255,9 +7352,18 @@ package body Einfo is
procedure Write_Field24_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Record_Type |
+ E_Record_Subtype |
+ E_Record_Type_With_Private |
+ E_Record_Subtype_With_Private =>
+ Write_Str ("Abstract_Interfaces");
+
when Subprogram_Kind =>
Write_Str ("Obsolescent_Warning");
+ when Task_Kind =>
+ Write_Str ("Task_Body_Procedure");
+
when others =>
Write_Str ("Field24??");
end case;
@@ -7270,6 +7376,10 @@ package body Einfo is
procedure Write_Field25_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Procedure |
+ E_Function =>
+ Write_Str ("Abstract_Interface_Alias");
+
when others =>
Write_Str ("Field25??");
end case;
--
cgit v1.2.1