OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

atree.ads, atree.adb: Add support for Elist24 field 

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.

From-SVN: r96489
This commit is contained in:
Javier Miranda 2005-03-15 16:54:14 +01:00 committed by Arnaud Charlet
parent 2f388d2db6
commit a9d8907c20
25 changed files with 1452 additions and 742 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/atree.adb
View File

@ -2919,9 +2919,15 @@ package body Atree is
end Elist15;
function Elist16 (N : Node_Id) return Elist_Id is
Value : constant Union_Id := Nodes.Table (N + 2).Field9;
begin
pragma Assert (Nkind (N) in N_Entity);
return Elist_Id (Nodes.Table (N + 2).Field9);
if Value = 0 then
return No_Elist;
else
return Elist_Id (Nodes.Table (N + 2).Field9);
end if;
end Elist16;
function Elist18 (N : Node_Id) return Elist_Id is
@ -2942,6 +2948,12 @@ package body Atree is
return Elist_Id (Nodes.Table (N + 3).Field10);
end Elist23;
function Elist24 (N : Node_Id) return Elist_Id is
begin
pragma Assert (Nkind (N) in N_Entity);
return Elist_Id (Nodes.Table (N + 4).Field6);
end Elist24;
function Name1 (N : Node_Id) return Name_Id is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
@ -4845,6 +4857,12 @@ package body Atree is
Nodes.Table (N + 3).Field10 := Union_Id (Val);
end Set_Elist23;
procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := Union_Id (Val);
end Set_Elist24;
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);

146
gcc/ada/atree.ads
View File

@ -75,62 +75,73 @@ package Atree is
-- a node contains a number of fields, much as though the nodes were
-- defined as a record type. The fields in a node are as follows:
-- Nkind Indicates the kind of the node. This field is present
-- in all nodes. The type is Node_Kind, which is declared
-- in the package Sinfo.
-- Nkind Indicates the kind of the node. This field is present
-- in all nodes. The type is Node_Kind, which is declared
-- in the package Sinfo.
-- Sloc Location (Source_Ptr) of the corresponding token
-- in the Source buffer. The individual node definitions
-- show which token is referenced by this pointer.
-- Sloc Location (Source_Ptr) of the corresponding token
-- in the Source buffer. The individual node definitions
-- show which token is referenced by this pointer.
-- In_List A flag used to indicate if the node is a member
-- In_List A flag used to indicate if the node is a member
-- of a node list.
-- Rewrite_Sub A flag set if the node has been rewritten using
-- the Rewrite procedure. The original value of the
-- node is retrievable with Original_Node.
-- Rewrite_Sub A flag set if the node has been rewritten using
-- the Rewrite procedure. The original value of the
-- node is retrievable with Original_Node.
-- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
-- node as a result of a call to Mark_Rewrite_Insertion.
-- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
-- node as a result of a call to Mark_Rewrite_Insertion.
-- Paren_Count A 2-bit count used on expression nodes to indicate
-- the level of parentheses. Up to 3 levels can be
-- accomodated. Anything more than 3 levels is treated
-- as 3 levels (conformance tests that complain about
-- this are hereby deemed pathological!) Set to zero
-- for non-subexpression nodes.
-- Paren_Count A 2-bit count used on expression nodes to indicate
-- the level of parentheses. Up to 3 levels can be
-- accomodated. Anything more than 3 levels is treated
-- as 3 levels (conformance tests that complain about
-- this are hereby deemed pathological!) Set to zero
-- for non-subexpression nodes.
-- Comes_From_Source
-- This flag is present in all nodes. It is set if the
-- node is built by the scanner or parser, and clear if
-- the node is built by the analyzer or expander. It
-- indicates that the node corresponds to a construct
-- that appears in the original source program.
-- This flag is present in all nodes. It is set if the
-- node is built by the scanner or parser, and clear if
-- the node is built by the analyzer or expander. It
-- indicates that the node corresponds to a construct
-- that appears in the original source program.
-- Analyzed This flag is present in all nodes. It is set when
-- a node is analyzed, and is used to avoid analyzing
-- the same node twice. Analysis includes expansion if
-- expansion is active, so in this case if the flag is
-- set it means the node has been analyzed and expanded.
-- Analyzed This flag is present in all nodes. It is set when
-- a node is analyzed, and is used to avoid analyzing
-- the same node twice. Analysis includes expansion if
-- expansion is active, so in this case if the flag is
-- set it means the node has been analyzed and expanded.
-- Error_Posted This flag is present in all nodes. It is set when
-- an error message is posted which is associated with
-- the flagged node. This is used to avoid posting more
-- than one message on the same node.
-- Error_Posted This flag is present in all nodes. It is set when
-- an error message is posted which is associated with
-- the flagged node. This is used to avoid posting more
-- than one message on the same node.
-- Field1
-- Field2
-- Field3
-- Field4
-- Field5 Five fields holding Union_Id values
-- Field5 Five fields holding Union_Id values
-- ElistN Synonym for FieldN typed as Elist_Id
-- ListN Synonym for FieldN typed as List_Id
-- NameN Synonym for FieldN typed as Name_Id
-- NodeN Synonym for FieldN typed as Node_Id
-- StrN Synonym for FieldN typed as String_Id
-- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
-- UrealN Synonym for FieldN typed as Ureal
-- ElistN Synonym for FieldN typed as Elist_Id (Empty = No_Elist)
-- ListN Synonym for FieldN typed as List_Id
-- NameN Synonym for FieldN typed as Name_Id
-- NodeN Synonym for FieldN typed as Node_Id
-- StrN Synonym for FieldN typed as String_Id
-- UintN Synonym for FieldN typed as Uint (Empty = Uint_0)
-- UrealN Synonym for FieldN typed as Ureal
-- Note: in the case of ElistN and UintN fields, it is common that we
-- end up with a value of Union_Id'(0) as the default value. This value
-- is meaningless as a Uint or Elist_Id value. We have two choices here.
-- We could require that all Uint and Elist fields be initialized to an
-- appropriate value, but that's error prone, since it would be easy to
-- miss an initialization. So instead we have the retrieval functions
-- generate an appropriate default value (Uint_0 or No_Elist). Probably
-- it would be cleaner to generate No_Uint in the Uint case but we got
-- stuck with representing an "unset" size value as zero early on, and
-- it will take a bit of fiddling to change that ???
-- Note: the actual usage of FieldN (i.e. whether it contains a Elist_Id,
-- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal), depends on the
@ -146,46 +157,46 @@ package Atree is
-- it is useful to be able to do untyped traversals, and an internal
-- package in Atree allows for direct untyped accesses in such cases.
-- Flag4 Fifteen Boolean flags (use depends on Nkind and
-- Flag5 Ekind, as described for FieldN). Again the access
-- Flag6 is usually via subprograms in Sinfo and Einfo which
-- Flag7 provide high-level synonyms for these flags, and
-- Flag8 contain debugging code that checks that the values
-- Flag9 in Nkind and Ekind are appropriate for the access.
-- Flag4 Fifteen Boolean flags (use depends on Nkind and
-- Flag5 Ekind, as described for FieldN). Again the access
-- Flag6 is usually via subprograms in Sinfo and Einfo which
-- Flag7 provide high-level synonyms for these flags, and
-- Flag8 contain debugging code that checks that the values
-- Flag9 in Nkind and Ekind are appropriate for the access.
-- Flag10
-- Flag11 Note that Flag1-3 are missing from this list. The
-- Flag12 first three flag positions are reserved for the
-- Flag13 standard flags (Comes_From_Source, Error_Posted,
-- Flag14 and Analyzed)
-- Flag11 Note that Flag1-3 are missing from this list. The
-- Flag12 first three flag positions are reserved for the
-- Flag13 standard flags (Comes_From_Source, Error_Posted,
-- Flag14 and Analyzed)
-- Flag15
-- Flag16
-- Flag17
-- Flag18
-- Link For a node, points to the Parent. For a list, points
-- to the list header. Note that in the latter case, a
-- client cannot modify the link field. This field is
-- private to the Atree package (but is also modified
-- by the Nlists package).
-- Link For a node, points to the Parent. For a list, points
-- to the list header. Note that in the latter case, a
-- client cannot modify the link field. This field is
-- private to the Atree package (but is also modified
-- by the Nlists package).
-- The following additional fields are present in extended nodes used
-- for entities (Nkind in N_Entity).
-- Ekind Entity type. This field indicates the type of the
-- entity, it is of type Entity_Kind which is defined
-- in package Einfo.
-- Ekind Entity type. This field indicates the type of the
-- entity, it is of type Entity_Kind which is defined
-- in package Einfo.
-- Flag19 197 additional flags
-- Flag19 197 additional flags
-- ...
-- Flag215
-- Convention Entity convention (Convention_Id value)
-- Convention Entity convention (Convention_Id value)
-- Field6 Additional Union_Id value stored in tree
-- Field6 Additional Union_Id value stored in tree
-- Node6 Synonym for Field6 typed as Node_Id
-- Elist6 Synonym for Field6 typed as Elist_Id
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-- Node6 Synonym for Field6 typed as Node_Id
-- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist)
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-- Similar definitions for Field7 to Field27 (and Node7-Node27,
-- Elist7-Elist27, Uint7-Uint27, Ureal7-Ureal27). Note that not all
@ -981,6 +992,9 @@ package Atree is
function Elist23 (N : Node_Id) return Elist_Id;
pragma Inline (Elist23);
function Elist24 (N : Node_Id) return Elist_Id;
pragma Inline (Elist24);
function Name1 (N : Node_Id) return Name_Id;
pragma Inline (Name1);
@ -1903,6 +1917,9 @@ package Atree is
procedure Set_Elist23 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist23);
procedure Set_Elist24 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist24);
procedure Set_Name1 (N : Node_Id; Val : Name_Id);
pragma Inline (Set_Name1);
@ -2602,7 +2619,6 @@ package Atree is
procedure Set_Flag215 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag215);
-- The following versions of Set_Noden also set the parent
-- pointer of the referenced node if it is non_Empty

4
gcc/ada/atree.h
View File

@ -381,7 +381,7 @@ extern Node_Id Current_Error_Node;
#define Field24(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
#define Field25(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field7)
#define Field26(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field8)
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.field9)
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
@ -425,9 +425,11 @@ extern Node_Id Current_Error_Node;
#define Elist8(N) Field8 (N)
#define Elist13(N) Field13 (N)
#define Elist15(N) Field15 (N)
#define Elist16(N) Field16 (N)
#define Elist18(N) Field18 (N)
#define Elist21(N) Field21 (N)
#define Elist23(N) Field23 (N)
#define Elist24(N) Field24 (N)
#define Name1(N) Field1 (N)
#define Name2(N) Field2 (N)

136
gcc/ada/einfo.adb
View File

@ -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;

96
gcc/ada/einfo.ads
View File

@ -286,6 +286,17 @@ package Einfo is
-- and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
-- Abstract_Interfaces (Elist24)
-- Present in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- Abstract_Interface_Alias (Node25)
-- Present in subprograms that cover a primitive operation of an abstract
-- interface type. Points to its associated interface subprogram. It is
-- used to register the subprogram in secondary dispatch table of the
-- interface (Ada 2005: AI-251).
-- Accept_Address (Elist21)
-- Present in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
@ -313,9 +324,9 @@ package Einfo is
-- rather irregular, and the semantic checks that depend on the nominal
-- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv).
-- Access_Disp_Table (Node16) [implementation base type only]
-- Access_Disp_Table (Elist16) [implementation base type only]
-- Present in record type entities. For a tagged type, points to the
-- dispatch table associated with the tagged type. For a non-tagged
-- dispatch tables associated with the tagged type. For a non-tagged
-- record, contains Empty.
-- Address_Clause (synthesized)
@ -1279,10 +1290,10 @@ package Einfo is
-- function of a tagged type which can dispatch on result
-- Has_Controlled_Component (Flag43) [base type only]
-- Present in composite type entities. Indicates that the type has a
-- component that either is a controlled type, or itself contains a
-- controlled component (i.e. either Has_Controlled_Component or
-- Is_Controlled is set for at least one component).
-- Present in all entities. Set only for composite type entities which
-- contain a component that either is a controlled type, or itself
-- contains controlled component (i.e. either Has_Controlled_Component
-- or Is_Controlled is set for at least one component).
-- Has_Convention_Pragma (Flag119)
-- Present in an entity for which a Convention, Import, or Export
@ -1959,6 +1970,15 @@ package Einfo is
-- Is_Integer_Type (synthesized)
-- Applies to all entities, true for integer types and subtypes
-- Is_Interface (Flag186)
-- Present in record types and subtypes to indicate that the current
-- entity corresponds with an abstract interface. Because abstract
-- interfaces are conceptually a special kind of abstract tagged types
-- we represent them by means of tagged record types and subtypes
-- marked with this attribute. This allows us to reuse most of the
-- compiler support for abstract tagged types to implement interfaces
-- (Ada 2005: AI-251).
-- Is_Internal (Flag17)
-- Present in all entities. Set to indicate an entity created during
-- semantic processing (e.g. an implicit type). Need more documentation
@ -2472,7 +2492,8 @@ package Einfo is
-- accurately a storage unit boundary). The front end checks that
-- component clauses respect this rule, and the back end ensures
-- that record packing does not violate this rule. Currently the
-- flag is set only for packed arrays longer than 64 bits.
-- flag is set only for packed arrays longer than 64 bits where
-- the component size is not a power of 2.
-- Needs_Debug_Info (Flag147)
-- Present in all entities. Set if the entity requires debugging
@ -3070,9 +3091,19 @@ package Einfo is
-- Present in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
-- Tag_Component (synthesized)
-- Applies to tagged record types, returns the entity for the _Tag
-- field in this record, which must be present.
-- Task_Body_Procedure (Node24)
-- Present in task types and subtypes. Points to the entity for
-- the task body procedure (as further described in Exp_Ch9, task
-- bodies are expanded into procedures). A convenient function to
-- retrieve this field is Sem_Util.Get_Task_Body_Procedure.
-- First_Tag_Component (synthesized)
-- Applies to tagged record types, returns the entity for the first
-- _Tag field in this record.
-- Next_Tag_Component (synthesized)
-- Applies to components of tagged record types. Given a _Tag field
-- of a record, returns the next _Tag field in this record.
-- Treat_As_Volatile (Flag41)
-- Present in all type entities, and also in constants, components and
@ -3921,6 +3952,7 @@ package Einfo is
-- Can_Never_Be_Null (Flag38)
-- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Freeze (Flag18)
-- Has_Fully_Qualified_Name (Flag173)
@ -4108,7 +4140,6 @@ package Einfo is
-- Packed_Array_Type (Node23)
-- Component_Alignment (special) (base type only)
-- Has_Component_Size_Clause (Flag68) (base type only)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Pragma_Pack (Flag121) (base type only)
-- Is_Aliased (Flag15)
-- Is_Constrained (Flag12)
@ -4137,7 +4168,6 @@ package Einfo is
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty in type case)
-- Last_Entity (Node20)
-- Has_Controlled_Component (Flag43) (base type only)
-- First_Component (synth)
-- (plus type attributes)
@ -4165,6 +4195,7 @@ package Einfo is
-- Treat_As_Volatile (Flag41)
-- Is_Protected_Private (synth)
-- Next_Component (synth)
-- Next_Tag_Component (synth)
-- E_Constant
-- E_Loop_Parameter
@ -4320,6 +4351,7 @@ package Einfo is
-- Inner_Instances (Elist23) (for a generic function)
-- Privals_Chain (Elist23) (for a protected function)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169)
@ -4567,6 +4599,7 @@ package Einfo is
-- Inner_Instances (Elist23) (for a generic procedure)
-- Privals_Chain (Elist23) (for a protected procedure)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure)
@ -4623,7 +4656,6 @@ package Einfo is
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ???
-- Uses_Sec_Stack (Flag95) ???
@ -4633,7 +4665,7 @@ package Einfo is
-- E_Record_Type
-- E_Record_Subtype
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Node16) (base type only)
-- Access_Disp_Table (Elist16) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
@ -4642,26 +4674,27 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- Stored_Constraint (Elist23)
-- Abstract_Interfaces (Elist24)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
-- First_Stored_Discriminant (synth)
-- Tag_Component (synth)
-- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Node16) (base type only)
-- Access_Disp_Table (Elist16) (base type only)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@ -4669,19 +4702,20 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Abstract_Interfaces (Elist24)
-- Has_Completion (Flag26)
-- Has_Completion_In_Body (Flag71)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
-- First_Stored_Discriminant (synth)
-- Tag_Component (synth)
-- First_Tag_Component (synth)
-- (plus type attributes)
-- E_Signed_Integer_Type
@ -4737,6 +4771,7 @@ package Einfo is
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
-- Stored_Constraint (Elist23)
-- Task_Body_Procedure (Node24)
-- Delay_Cleanups (Flag114)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
@ -5006,11 +5041,13 @@ package Einfo is
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
function Abstract_Interfaces (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return E;
function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Abstract_Interface_Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Final_Chain (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
@ -5189,6 +5226,7 @@ package Einfo is
function Is_Immediately_Visible (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Interface (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Is_Internal (Id : E) return B;
function Is_Interrupt_Handler (Id : E) return B;
@ -5302,6 +5340,7 @@ package Einfo is
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Init_Proc (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
function Task_Body_Procedure (Id : E) return N;
function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
function Unset_Reference (Id : E) return N;
@ -5416,7 +5455,8 @@ package Einfo is
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
function Tag_Component (Id : E) return E;
function First_Tag_Component (Id : E) return E;
function Next_Tag_Component (Id : E) return E;
function Type_High_Bound (Id : E) return N;
function Type_Low_Bound (Id : E) return N;
function Underlying_Type (Id : E) return E;
@ -5481,11 +5521,13 @@ package Einfo is
-- Attribute Set Procedures --
------------------------------
procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : E);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Abstract_Interface_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Final_Chain (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
@ -5667,6 +5709,7 @@ package Einfo is
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Interface (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Is_Internal (Id : E; V : B := True);
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
@ -5781,6 +5824,7 @@ package Einfo is
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Init_Proc (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
procedure Set_Task_Body_Procedure (Id : E; V : N);
procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Unset_Reference (Id : E; V : N);
@ -6012,10 +6056,12 @@ package Einfo is
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
pragma Inline (Abstract_Interfaces);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
pragma Inline (Abstract_Interface_Alias);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Final_Chain);
@ -6216,6 +6262,7 @@ package Einfo is
pragma Inline (Is_Imported);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Inlined);
pragma Inline (Is_Interface);
pragma Inline (Is_Instantiated);
pragma Inline (Is_Integer_Type);
pragma Inline (Is_Internal);
@ -6348,6 +6395,7 @@ package Einfo is
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Init_Proc);
pragma Inline (Suppress_Style_Checks);
pragma Inline (Task_Body_Procedure);
pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
pragma Inline (Unset_Reference);
@ -6362,10 +6410,12 @@ package Einfo is
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
pragma Inline (Set_Abstract_Interfaces);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Abstract_Interface_Alias);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Final_Chain);
@ -6543,6 +6593,7 @@ package Einfo is
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Interface);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Is_Internal);
pragma Inline (Set_Is_Interrupt_Handler);
@ -6657,6 +6708,7 @@ package Einfo is
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Init_Proc);
pragma Inline (Set_Suppress_Style_Checks);
pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Unset_Reference);

68
gcc/ada/exp_aggr.adb
View File

@ -910,12 +910,14 @@ package body Exp_Aggr is
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Indexed_Comp),
Selector_Name =>
New_Reference_To (Tag_Component (Comp_Type), Loc)),
New_Reference_To
(First_Tag_Component (Comp_Type), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Comp_Type), Loc)));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Comp_Type))),
Loc)));
Append_To (L, A);
end if;
@ -1711,8 +1713,9 @@ package body Exp_Aggr is
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(Find_Prim_Op (RTE (RE_Limited_Record_Controller),
Name_Initialize), Loc),
(Find_Prim_Op
(RTE (RE_Limited_Record_Controller), Name_Initialize),
Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
else
@ -1727,8 +1730,10 @@ package body Exp_Aggr is
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
Name_Initialize), Loc),
New_Reference_To
(Find_Prim_Op
(RTE (RE_Record_Controller), Name_Initialize),
Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
@ -1869,13 +1874,16 @@ package body Exp_Aggr is
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Reference_To (
Tag_Component (Base_Type (Typ)), Loc)),
Selector_Name =>
New_Reference_To
(First_Tag_Component (Base_Type (Typ)), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Base_Type (Typ)), Loc)));
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Base_Type (Typ)))),
Loc)));
Set_Assignment_OK (Name (Instr));
Append_To (L, Instr);
@ -2090,12 +2098,14 @@ package body Exp_Aggr is
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Comp_Expr),
Selector_Name =>
New_Reference_To (Tag_Component (Comp_Type), Loc)),
New_Reference_To
(First_Tag_Component (Comp_Type), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Comp_Type), Loc)));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Comp_Type))),
Loc)));
Append_To (L, Instr);
end if;
@ -2172,11 +2182,14 @@ package body Exp_Aggr is
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Component (Base_Type (Typ)), Loc)),
New_Reference_To
(First_Tag_Component (Base_Type (Typ)), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (Base_Type (Typ)), Loc)));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
Loc)));
Append_To (L, Instr);
end if;
@ -2186,9 +2199,10 @@ package body Exp_Aggr is
if Present (Obj)
and then Finalize_Storage_Only (Typ)
and then (Is_Library_Level_Entity (Obj)
or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
= Standard_True)
and then
(Is_Library_Level_Entity (Obj)
or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
Standard_True)
then
Attach := Make_Integer_Literal (Loc, 0);
@ -2232,8 +2246,9 @@ package body Exp_Aggr is
Set_Assignment_OK (Ref);
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
Name =>
New_Reference_To
(Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
@ -4282,7 +4297,9 @@ package body Exp_Aggr is
Parent_Expr => A);
else
Expand_Record_Aggregate (N,
Orig_Tag => New_Occurrence_Of (Access_Disp_Table (Typ), Loc),
Orig_Tag =>
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
Parent_Expr => A);
end if;
end if;
@ -4649,7 +4666,9 @@ package body Exp_Aggr is
elsif Java_VM then
Tag_Value := Empty;
else
Tag_Value := New_Occurrence_Of (Access_Disp_Table (Typ), Loc);
Tag_Value :=
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
end if;
-- For a derived type, an aggregate for the parent is formed with
@ -4712,7 +4731,8 @@ package body Exp_Aggr is
elsif not Java_VM then
declare
Tag_Name : constant Node_Id :=
New_Occurrence_Of (Tag_Component (Typ), Loc);
New_Occurrence_Of
(First_Tag_Component (Typ), Loc);
Typ_Tag : constant Entity_Id := RTE (RE_Tag);
Conv_Node : constant Node_Id :=
Unchecked_Convert_To (Typ_Tag, Tag_Value);

47
gcc/ada/exp_attr.adb
View File

@ -122,13 +122,6 @@ package body Exp_Attr is
-- A reference to a type within its own scope is resolved to a reference
-- to the current instance of the type in its initialization procedure.
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
-- Returns the TSS of name Nam of Typ, or of its closest ancestor defining
-- such a TSS. Empty is returned is neither Typ nor any of its ancestors
-- have such a TSS.
function Find_Stream_Subprogram
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
@ -3510,7 +3503,8 @@ package body Exp_Attr is
if not Java_VM then
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
@ -3519,7 +3513,7 @@ package body Exp_Attr is
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Pref),
Selector_Name =>
New_Reference_To (Tag_Component (Ttyp), Loc)));
New_Reference_To (First_Tag_Component (Ttyp), Loc)));
Analyze_And_Resolve (N, RTE (RE_Tag));
end if;
end Tag;
@ -4423,41 +4417,6 @@ package body Exp_Attr is
Reason => CE_Overflow_Check_Failed));
end Expand_Pred_Succ;
------------------------
-- Find_Inherited_TSS --
------------------------
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id
is
Btyp : Entity_Id := Typ;
Proc : Entity_Id;
begin
loop
Btyp := Base_Type (Btyp);
Proc := TSS (Btyp, Nam);
exit when Present (Proc)
or else not Is_Derived_Type (Btyp);
-- If Typ is a derived type, it may inherit attributes from
-- some ancestor.
Btyp := Etype (Btyp);
end loop;
if No (Proc) then
-- If nothing else, use the TSS of the root type
Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;
return Proc;
end Find_Inherited_TSS;
----------------------------
-- Find_Stream_Subprogram --
----------------------------

23
gcc/ada/exp_ch11.adb
View File

@ -1067,6 +1067,29 @@ package body Exp_Ch11 is
Str : String_Id;
begin
-- If a string expression is present, then the raise statement is
-- converted to a call:
-- Raise_Exception (exception-name'Identity, string);
-- and there is nothing else to do
if Present (Expression (N)) then
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Identity),
Expression (N))));
Analyze (N);
return;
end if;
-- Remaining processing is for the case where no string expression
-- is present.
-- There is no expansion needed for statement "raise <exception>;" when
-- compiling for the JVM since the JVM has a built-in exception
-- mechanism. However we need the keep the expansion for "raise;"

352
gcc/ada/exp_ch3.adb
View File

@ -1512,11 +1512,12 @@ package body Exp_Ch3 is
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
New_Reference_To (First_Tag_Component (Typ), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (Typ), Loc))));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc))));
end if;
-- Adjust the component if controlled except if it is an
@ -1825,10 +1826,11 @@ package body Exp_Ch3 is
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name =>
New_Reference_To (Tag_Component (Rec_Type), Loc)),
New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
Expression =>
New_Reference_To (Access_Disp_Table (Rec_Type), Loc));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
-- The tag must be inserted before the assignments to other
-- components, because the initial value of the component may
@ -3497,18 +3499,20 @@ package body Exp_Ch3 is
end;
end if;
-- For tagged types, when an init value is given, the tag has
-- to be re-initialized separately in order to avoid the
-- propagation of a wrong tag coming from a view conversion
-- unless the type is class wide (in this case the tag comes
-- from the init value). Suppress the tag assignment when
-- Java_VM because JVM tags are represented implicitly
-- in objects. Ditto for types that are CPP_CLASS.
-- For tagged types, when an init value is given, the tag has to
-- be re-initialized separately in order to avoid the propagation
-- of a wrong tag coming from a view conversion unless the type
-- is class wide (in this case the tag comes from the init
-- value). Suppress the tag assignment when Java_VM because JVM
-- tags are represented implicitly in objects. Ditto for types
-- that are CPP_CLASS, and for initializations that are
-- aggregates, because they have to have the right tag.
if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ)
and then not Java_VM
and then Nkind (Expr) /= N_Aggregate
then
-- The re-assignment of the tag has to be done even if
-- the object is a constant
@ -3517,7 +3521,7 @@ package body Exp_Ch3 is
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Def_Id, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc));
New_Reference_To (First_Tag_Component (Typ), Loc));
Set_Assignment_OK (New_Ref);
@ -3527,7 +3531,10 @@ package body Exp_Ch3 is
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Access_Disp_Table (Base_Type (Typ)), Loc))));
(Node
(First_Elmt
(Access_Disp_Table (Base_Type (Typ)))),
Loc))));
-- For discrete types, set the Is_Known_Valid flag if the
-- initializing value is known to be valid.
@ -3553,8 +3560,8 @@ package body Exp_Ch3 is
end if;
-- For access types set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also
-- set Can_Never_Be_Null if this is a constant.
-- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant.
if Known_Non_Null (Expr) then
Set_Is_Known_Non_Null (Def_Id);
@ -3575,21 +3582,33 @@ package body Exp_Ch3 is
end if;
end if;
if Is_Possibly_Unaligned_Slice (Expr) then
-- Cases where the back end cannot handle the initialization
-- directly. In such cases, we expand an assignment that will
-- be appropriately handled by Expand_N_Assignment_Statement.
-- Make a separate assignment that will be expanded into a
-- loop, to bypass back-end problems with misaligned arrays.
-- The exclusion of the unconstrained case is wrong, but for
-- now it is too much trouble ???
if (Is_Possibly_Unaligned_Slice (Expr)
or else (Is_Possibly_Unaligned_Object (Expr)
and then not Represented_As_Scalar (Etype (Expr))))
-- The exclusion of the unconstrained case is wrong, but for
-- now it is too much trouble ???
and then not (Is_Array_Type (Etype (Expr))
and then not Is_Constrained (Etype (Expr)))
then
declare
Stat : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Def_Id, Loc),
Name => New_Reference_To (Def_Id, Loc),
Expression => Relocate_Node (Expr));
begin
Set_Expression (N, Empty);
Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
Set_No_Ctrl_Actions (Stat);
Insert_After (N, Stat);
Analyze (Stat);
end;
@ -3612,10 +3631,10 @@ package body Exp_Ch3 is
-- Expand_N_Subtype_Indication --
---------------------------------
-- Add a check on the range of the subtype. The static case is
-- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3,
-- but we still need to check here for the static case in order to
-- avoid generating extraneous expanded code.
-- Add a check on the range of the subtype. The static case is partially
-- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
-- to check here for the static case in order to avoid generating
-- extraneous expanded code.
procedure Expand_N_Subtype_Indication (N : Node_Id) is
Ran : constant Node_Id := Range_Expression (Constraint (N));
@ -3634,18 +3653,17 @@ package body Exp_Ch3 is
-- Expand_N_Variant_Part --
---------------------------
-- If the last variant does not contain the Others choice, replace
-- it with an N_Others_Choice node since Gigi always wants an Others.
-- Note that we do not bother to call Analyze on the modified variant
-- part, since it's only effect would be to compute the contents of
-- the Others_Discrete_Choices node laboriously, and of course we
-- already know the list of choices that corresponds to the others
-- choice (it's the list we are replacing!)
-- If the last variant does not contain the Others choice, replace it with
-- an N_Others_Choice node since Gigi always wants an Others. Note that we
-- do not bother to call Analyze on the modified variant part, since it's
-- only effect would be to compute the contents of the
-- Others_Discrete_Choices node laboriously, and of course we already know
-- the list of choices that corresponds to the others choice (it's the
-- list we are replacing!)
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
begin
if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Last_Var));
@ -3737,9 +3755,9 @@ package body Exp_Ch3 is
Set_Null_Present (Comp_List, False);
else
-- The controller cannot be placed before the _Parent field
-- since gigi lays out field in order and _parent must be
-- first to preserve the polymorphism of tagged types.
-- The controller cannot be placed before the _Parent field since
-- gigi lays out field in order and _parent must be first to
-- preserve the polymorphism of tagged types.
First_Comp := First (Component_Items (Comp_List));
@ -3757,9 +3775,9 @@ package body Exp_Ch3 is
Set_Ekind (Ent, E_Component);
Init_Component_Location (Ent);
-- Move the _controller entity ahead in the list of internal
-- entities of the enclosing record so that it is selected
-- instead of a potentially inherited one.
-- Move the _controller entity ahead in the list of internal entities
-- of the enclosing record so that it is selected instead of a
-- potentially inherited one.
declare
E : constant Entity_Id := Last_Entity (T);
@ -3818,7 +3836,7 @@ package body Exp_Ch3 is
Comp_Decl :=
Make_Component_Declaration (Sloc_N,
Defining_Identifier => Tag_Component (T),
Defining_Identifier => First_Tag_Component (T),
Component_Definition =>
Make_Component_Definition (Sloc_N,
Aliased_Present => False,
@ -3835,8 +3853,8 @@ package body Exp_Ch3 is
end if;
-- We don't Analyze the whole expansion because the tag component has
-- already been analyzed previously. Here we just insure that the
-- tree is coherent with the semantic decoration
-- already been analyzed previously. Here we just insure that the tree
-- is coherent with the semantic decoration
Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
@ -3856,10 +3874,10 @@ package body Exp_Ch3 is
begin
if not Is_Bit_Packed_Array (Typ) then
-- If the component contains tasks, so does the array type.
-- This may not be indicated in the array type because the
-- component may have been a private type at the point of
-- definition. Same if component type is controlled.
-- If the component contains tasks, so does the array type. This may
-- not be indicated in the array type because the component may have
-- been a private type at the point of definition. Same if component
-- type is controlled.
Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
Set_Has_Controlled_Component (Base,
@ -3868,9 +3886,9 @@ package body Exp_Ch3 is
if No (Init_Proc (Base)) then
-- If this is an anonymous array created for a declaration
-- with an initial value, its init_proc will never be called.
-- The initial value itself may have been expanded into assign-
-- If this is an anonymous array created for a declaration with
-- an initial value, its init_proc will never be called. The
-- initial value itself may have been expanded into assign-
-- ments, in which case the object declaration is carries the
-- No_Initialization flag.
@ -3911,9 +3929,9 @@ package body Exp_Ch3 is
end if;
end if;
-- For packed case, there is a default initialization, except
-- if the component type is itself a packed structure with an
-- initialization procedure.
-- For packed case, there is a default initialization, except if the
-- component type is itself a packed structure with an initialization
-- procedure.
elsif Present (Init_Proc (Component_Type (Base)))
and then No (Base_Init_Proc (Base))
@ -3943,8 +3961,8 @@ package body Exp_Ch3 is
pragma Warnings (Off, Func);
begin
-- Various optimization are possible if the given representation
-- is contiguous.
-- Various optimization are possible if the given representation is
-- contiguous.
Is_Contiguous := True;
Ent := First_Literal (Typ);
@ -3987,9 +4005,9 @@ package body Exp_Ch3 is
-- typA : array (Natural range 0 .. num - 1) of ctype :=
-- (v, v, v, v, v, ....)
-- where ctype is the corresponding integer type. If the
-- representation is contiguous, we only keep the first literal,
-- which provides the offset for Pos_To_Rep computations.
-- where ctype is the corresponding integer type. If the representation
-- is contiguous, we only keep the first literal, which provides the
-- offset for Pos_To_Rep computations.
Arr :=
Make_Defining_Identifier (Loc,
@ -4044,22 +4062,22 @@ package body Exp_Ch3 is
-- representation) raises Constraint_Error or returns a unique value
-- of minus one. The latter case is used, e.g. in 'Valid code.
-- Note: the reason we use Enum_Rep values in the case here is to
-- avoid the code generator making inappropriate assumptions about
-- the range of the values in the case where the value is invalid.
-- ityp is a signed or unsigned integer type of appropriate width.
-- Note: the reason we use Enum_Rep values in the case here is to avoid
-- the code generator making inappropriate assumptions about the range
-- of the values in the case where the value is invalid. ityp is a
-- signed or unsigned integer type of appropriate width.
-- Note: if exceptions are not supported, then we suppress the raise
-- and return -1 unconditionally (this is an erroneous program in any
-- case and there is no obligation to raise Constraint_Error here!)
-- We also do this if pragma Restrictions (No_Exceptions) is active.
-- case and there is no obligation to raise Constraint_Error here!) We
-- also do this if pragma Restrictions (No_Exceptions) is active.
-- Representations are signed
if Enumeration_Rep (First_Literal (Typ)) < 0 then
-- The underlying type is signed. Reset the Is_Unsigned_Type
-- explicitly, because it might have been inherited from a
-- explicitly, because it might have been inherited from
-- parent type.
Set_Is_Unsigned_Type (Typ, False);
@ -4080,8 +4098,8 @@ package body Exp_Ch3 is
end if;
end if;
-- The body of the function is a case statement. First collect
-- case alternatives, or optimize the contiguous case.
-- The body of the function is a case statement. First collect case
-- alternatives, or optimize the contiguous case.
Lst := New_List;
@ -4303,10 +4321,10 @@ package body Exp_Ch3 is
end loop;
-- Creation of the Dispatch Table. Note that a Dispatch Table is
-- created for regular tagged types as well as for Ada types
-- deriving from a C++ Class, but not for tagged types directly
-- corresponding to the C++ classes. In the later case we assume
-- that the Vtable is created in the C++ side and we just use it.
-- created for regular tagged types as well as for Ada types deriving
-- from a C++ Class, but not for tagged types directly corresponding to
-- the C++ classes. In the later case we assume that the Vtable is
-- created in the C++ side and we just use it.
if Is_Tagged_Type (Def_Id) then
if Is_CPP_Class (Def_Id) then
@ -4314,18 +4332,17 @@ package body Exp_Ch3 is
Set_Default_Constructor (Def_Id);
else
-- Usually inherited primitives are not delayed but the first
-- Ada extension of a CPP_Class is an exception since the
-- address of the inherited subprogram has to be inserted in
-- the new Ada Dispatch Table and this is a freezing action
-- (usually the inherited primitive address is inserted in the
-- DT by Inherit_DT)
-- Usually inherited primitives are not delayed but the first Ada
-- extension of a CPP_Class is an exception since the address of
-- the inherited subprogram has to be inserted in the new Ada
-- Dispatch Table and this is a freezing action (usually the
-- inherited primitive address is inserted in the DT by
-- Inherit_DT)
-- Similarly, if this is an inherited operation whose parent
-- is not frozen yet, it is not in the DT of the parent, and
-- we generate an explicit freeze node for the inherited
-- operation, so that it is properly inserted in the DT of the
-- current type.
-- Similarly, if this is an inherited operation whose parent is
-- not frozen yet, it is not in the DT of the parent, and we
-- generate an explicit freeze node for the inherited operation,
-- so that it is properly inserted in the DT of the current type.
declare
Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
@ -4355,11 +4372,10 @@ package body Exp_Ch3 is
Expand_Tagged_Root (Def_Id);
end if;
-- Unfreeze momentarily the type to add the predefined
-- primitives operations. The reason we unfreeze is so
-- that these predefined operations will indeed end up
-- as primitive operations (which must be before the
-- freeze point).
-- Unfreeze momentarily the type to add the predefined primitives
-- operations. The reason we unfreeze is so that these predefined
-- operations will indeed end up as primitive operations (which
-- must be before the freeze point).
Set_Is_Frozen (Def_Id, False);
Make_Predefined_Primitive_Specs
@ -4369,22 +4385,22 @@ package body Exp_Ch3 is
Set_All_DT_Position (Def_Id);
-- Add the controlled component before the freezing actions
-- it is referenced in those actions.
-- referenced in those actions.
if Has_New_Controlled_Component (Def_Id) then
Expand_Record_Controller (Def_Id);
end if;
-- Suppress creation of a dispatch table when Java_VM because
-- the dispatching mechanism is handled internally by the JVM.
-- Suppress creation of a dispatch table when Java_VM because the
-- dispatching mechanism is handled internally by the JVM.
if not Java_VM then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
-- Make sure that the primitives Initialize, Adjust and
-- Finalize are Frozen before other TSS subprograms. We
-- don't want them Frozen inside.
-- Make sure that the primitives Initialize, Adjust and Finalize
-- are Frozen before other TSS subprograms. We don't want them
-- Frozen inside.
if Is_Controlled (Def_Id) then
if not Is_Limited_Type (Def_Id) then
@ -4408,8 +4424,8 @@ package body Exp_Ch3 is
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
end if;
-- In the non-tagged case, an equality function is provided only
-- for variant records (that are not unchecked unions).
-- In the non-tagged case, an equality function is provided only for
-- variant records (that are not unchecked unions).
elsif Has_Discriminants (Def_Id)
and then not Is_Limited_Type (Def_Id)
@ -4428,10 +4444,10 @@ package body Exp_Ch3 is
end if;
-- Before building the record initialization procedure, if we are
-- dealing with a concurrent record value type, then we must go
-- through the discriminants, exchanging discriminals between the
-- concurrent type and the concurrent record value type. See the
-- section "Handling of Discriminants" in the Einfo spec for details.
-- dealing with a concurrent record value type, then we must go through
-- the discriminants, exchanging discriminals between the concurrent
-- type and the concurrent record value type. See the section "Handling
-- of Discriminants" in the Einfo spec for details.
if Is_Concurrent_Record_Type (Def_Id)
and then Has_Discriminants (Def_Id)
@ -4472,10 +4488,9 @@ package body Exp_Ch3 is
Adjust_Discriminants (Def_Id);
Build_Record_Init_Proc (Type_Decl, Def_Id);
-- For tagged type, build bodies of primitive operations. Note
-- that we do this after building the record initialization
-- experiment, since the primitive operations may need the
-- initialization routine
-- For tagged type, build bodies of primitive operations. Note that we
-- do this after building the record initialization experiment, since
-- the primitive operations may need the initialization routine
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
@ -4525,15 +4540,16 @@ package body Exp_Ch3 is
-- Freeze_Type --
-----------------
-- Full type declarations are expanded at the point at which the type
-- is frozen. The formal N is the Freeze_Node for the type. Any statements
-- or declarations generated by the freezing (e.g. the procedure generated
-- Full type declarations are expanded at the point at which the type is
-- frozen. The formal N is the Freeze_Node for the type. Any statements or
-- declarations generated by the freezing (e.g. the procedure generated
-- for initialization) are chained in the Acions field list of the freeze
-- node using Append_Freeze_Actions.
procedure Freeze_Type (N : Node_Id) is
function Freeze_Type (N : Node_Id) return Boolean is
Def_Id : constant Entity_Id := Entity (N);
RACW_Seen : Boolean := False;
Result : Boolean := False;
begin
-- Process associated access types needing special processing
@ -4566,13 +4582,13 @@ package body Exp_Ch3 is
if Ekind (Def_Id) = E_Record_Type then
Freeze_Record_Type (N);
-- The subtype may have been declared before the type was frozen.
-- If the type has controlled components it is necessary to create
-- the entity for the controller explicitly because it did not
-- exist at the point of the subtype declaration. Only the entity is
-- needed, the back-end will obtain the layout from the type.
-- This is only necessary if this is constrained subtype whose
-- component list is not shared with the base type.
-- The subtype may have been declared before the type was frozen. If
-- the type has controlled components it is necessary to create the
-- entity for the controller explicitly because it did not exist at
-- the point of the subtype declaration. Only the entity is needed,
-- the back-end will obtain the layout from the type. This is only
-- necessary if this is constrained subtype whose component list is
-- not shared with the base type.
elsif Ekind (Def_Id) = E_Record_Subtype
and then Has_Discriminants (Def_Id)
@ -4596,8 +4612,20 @@ package body Exp_Ch3 is
end if;
end;
-- Similar process if the controller of the subtype is not
-- present but the parent has it. This can happen with constrained
if Is_Itype (Def_Id)
and then Is_Record_Type (Underlying_Type (Scope (Def_Id)))
then
-- The freeze node is only used to introduce the controller,
-- the back-end has no use for it for a discriminated
-- component.
Set_Freeze_Node (Def_Id, Empty);
Set_Has_Delayed_Freeze (Def_Id, False);
Result := True;
end if;
-- Similar process if the controller of the subtype is not present
-- but the parent has it. This can happen with constrained
-- record components where the subtype is an itype.
elsif Ekind (Def_Id) = E_Record_Subtype
@ -4620,7 +4648,7 @@ package body Exp_Ch3 is
Set_Freeze_Node (Def_Id, Empty);
Set_Has_Delayed_Freeze (Def_Id, False);
Remove (N);
Result := True;
end;
end if;
@ -4689,9 +4717,9 @@ package body Exp_Ch3 is
DT_Align : Node_Id;
begin
-- For unconstrained composite types we give a size of
-- zero so that the pool knows that it needs a special
-- algorithm for variable size object allocation.
-- For unconstrained composite types we give a size of zero
-- so that the pool knows that it needs a special algorithm
-- for variable size object allocation.
if Is_Composite_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
@ -4718,11 +4746,10 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Def_Id), 'P'));
-- We put the code associated with the pools in the
-- entity that has the later freeze node, usually the
-- acces type but it can also be the designated_type;
-- because the pool code requires both those types to be
-- frozen
-- We put the code associated with the pools in the entity
-- that has the later freeze node, usually the acces type
-- but it can also be the designated_type; because the pool
-- code requires both those types to be frozen
if Is_Frozen (Desig_Type)
and then (not Present (Freeze_Node (Desig_Type))
@ -4784,16 +4811,16 @@ package body Exp_Ch3 is
null;
end if;
-- For access-to-controlled types (including class-wide types
-- and Taft-amendment types which potentially have controlled
-- components), expand the list controller object that will
-- store the dynamically allocated objects. Do not do this
-- For access-to-controlled types (including class-wide types and
-- Taft-amendment types which potentially have controlled
-- components), expand the list controller object that will store
-- the dynamically allocated objects. Do not do this
-- transformation for expander-generated access types, but do it
-- for types that are the full view of types derived from other
-- private types. Also suppress the list controller in the case
-- of a designated type with convention Java, since this is used
-- when binding to Java API specs, where there's no equivalent
-- of a finalization list and we don't want to pull in the
-- when binding to Java API specs, where there's no equivalent of
-- a finalization list and we don't want to pull in the
-- finalization support if not needed.
if not Comes_From_Source (Def_Id)
@ -4864,20 +4891,21 @@ package body Exp_Ch3 is
and then Freeze_Node (Full_View (Def_Id)) = N
then
Set_Entity (N, Full_View (Def_Id));
Freeze_Type (N);
Result := Freeze_Type (N);
Set_Entity (N, Def_Id);
-- All other types require no expander action. There are such
-- cases (e.g. task types and protected types). In such cases,
-- the freeze nodes are there for use by Gigi.
-- All other types require no expander action. There are such cases
-- (e.g. task types and protected types). In such cases, the freeze
-- nodes are there for use by Gigi.
end if;
Freeze_Stream_Operations (N, Def_Id);
return Result;
exception
when RE_Not_Available =>
return;
return False;
end Freeze_Type;
-------------------------
@ -4902,10 +4930,10 @@ package body Exp_Ch3 is
-- These are the values computed by the procedure Check_Subtype_Bounds
procedure Check_Subtype_Bounds;
-- This procedure examines the subtype T, and its ancestor subtypes
-- and derived types to determine the best known information about
-- the bounds of the subtype. After the call Lo_Bound is set either
-- to No_Uint if no information can be determined, or to a value which
-- This procedure examines the subtype T, and its ancestor subtypes and
-- derived types to determine the best known information about the
-- bounds of the subtype. After the call Lo_Bound is set either to
-- No_Uint if no information can be determined, or to a value which
-- represents a known low bound, i.e. a valid value of the subtype can
-- not be less than this value. Hi_Bound is similarly set to a known
-- high bound (valid value cannot be greater than this).
@ -4969,16 +4997,16 @@ package body Exp_Ch3 is
begin
-- For a private type, we should always have an underlying type
-- (because this was already checked in Needs_Simple_Initialization).
-- What we do is to get the value for the underlying type and then
-- do an Unchecked_Convert to the private type.
-- What we do is to get the value for the underlying type and then do
-- an Unchecked_Convert to the private type.
if Is_Private_Type (T) then
Val := Get_Simple_Init_Val (Underlying_Type (T), Loc, Size);
-- A special case, if the underlying value is null, then qualify
-- it with the underlying type, so that the null is properly typed
-- Similarly, if it is an aggregate it must be qualified, because
-- an unchecked conversion does not provide a context for it.
-- A special case, if the underlying value is null, then qualify it
-- with the underlying type, so that the null is properly typed
-- Similarly, if it is an aggregate it must be qualified, because an
-- unchecked conversion does not provide a context for it.
if Nkind (Val) = N_Null
or else Nkind (Val) = N_Aggregate
@ -5007,9 +5035,9 @@ package body Exp_Ch3 is
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars);
-- Compute size of object. If it is given by the caller, we can
-- use it directly, otherwise we use Esize (T) as an estimate. As
-- far as we know this covers all cases correctly.
-- Compute size of object. If it is given by the caller, we can use
-- it directly, otherwise we use Esize (T) as an estimate. As far as
-- we know this covers all cases correctly.
if Size = No_Uint or else Size <= Uint_0 then
Size_To_Use := UI_Max (Uint_1, Esize (T));
@ -5074,9 +5102,9 @@ package body Exp_Ch3 is
begin
-- Normally we like to use the most negative number. The
-- one exception is when this number is in the known subtype
-- range and the largest positive number is not in the known
-- subtype range.
-- one exception is when this number is in the known
-- subtype range and the largest positive number is not in
-- the known subtype range.
-- For this exceptional case, use largest positive value
@ -5491,18 +5519,6 @@ package body Exp_Ch3 is
begin
Renamed_Eq := Empty;
-- Spec of _Alignment
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Integer));
-- Spec of _Size
Append_To (Res, Predef_Spec_Or_Body (Loc,
@ -5515,6 +5531,18 @@ package body Exp_Ch3 is
Ret_Type => Standard_Long_Long_Integer));
-- Spec of _Alignment
Append_To (Res, Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Name_uAlignment,
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Integer));
-- Specs for dispatching stream attributes. We skip these for limited
-- types, since there is no question of dispatching in the limited case.

10
gcc/ada/exp_ch3.ads
View File

@ -82,9 +82,13 @@ package Exp_Ch3 is
-- initialization call corresponds to a default initialized component
-- of an aggregate.
procedure Freeze_Type (N : Node_Id);
-- This procedure executes the freezing actions associated with the given
-- freeze type node N.
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted.
-- We delete the node if it is present just for front end purpose and
-- we don't want Gigi to see the node. This function can't delete the
-- node itself since it would confuse any remaining processing of the
-- freeze node.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific

171
gcc/ada/exp_ch4.adb
View File

@ -458,11 +458,13 @@ package body Exp_Ch4 is
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (T), Loc)),
New_Reference_To (First_Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (T), Loc)));
New_Reference_To
(Elists.Node (First_Elmt (Access_Disp_Table (T))),
Loc)));
-- The previous assignment has to be done in any case
@ -487,12 +489,13 @@ package body Exp_Ch4 is
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
New_Reference_To (Tag_Component (Utyp), Loc)),
New_Reference_To (First_Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Utyp), Loc)));
Elists.Node (First_Elmt (Access_Disp_Table (Utyp))),
Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
@ -1063,10 +1066,16 @@ package body Exp_Ch4 is
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
-- If some (sub)component is an unchecked_union, the whole
-- operation will raise program error.
-- If some (sub)component is an unchecked_union, the whole operation
-- will raise program error.
if Nkind (Test) = N_Raise_Program_Error then
-- This node is going to be inserted at a location where a
-- statement is expected: clear its Etype so analysis will
-- set it to the expected Standard_Void_Type.
Set_Etype (Test, Empty);
return Test;
else
@ -1160,6 +1169,7 @@ package body Exp_Ch4 is
Handle_One_Dimension (N + 1, Next_Index (Index)));
if Need_Separate_Indexes then
-- Generate guard for loop, followed by increments of indices
Append_To (Stm_List,
@ -1188,8 +1198,8 @@ package body Exp_Ch4 is
Expressions => New_List (New_Reference_To (Bn, Loc)))));
end if;
-- If separate indexes, we need a declare block for An and Bn,
-- and a loop without an iteration scheme.
-- If separate indexes, we need a declare block for An and Bn, and a
-- loop without an iteration scheme.
if Need_Separate_Indexes then
Loop_Stm :=
@ -1419,61 +1429,69 @@ package body Exp_Ch4 is
Typ : constant Entity_Id := Etype (N);
begin
if Is_Bit_Packed_Array (Typ) then
-- Special case of bit packed array where both operands are known
-- to be properly aligned. In this case we use an efficient run time
-- routine to carry out the operation (see System.Bit_Ops).
if Is_Bit_Packed_Array (Typ)
and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
then
Expand_Packed_Boolean_Operator (N);
else
-- For the normal non-packed case, the general expansion is
-- to build a function for carrying out the comparison (using
-- Make_Boolean_Array_Op) and then inserting it into the tree.
-- The original operator node is then rewritten as a call to
-- this function.
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
Ensure_Defined (Etype (L), N);
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
if Nkind (Parent (N)) = N_Assignment_Statement
and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
then
Build_Boolean_Array_Proc_Call (Parent (N), L, R);
elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And
and then
Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
then
return;
else
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
-- Now rewrite the expression with a call
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations =>
New_List
(L, Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
Analyze_And_Resolve (N, Typ);
end if;
end;
return;
end if;
-- For the normal non-packed case, the general expansion is to build
-- function for carrying out the comparison (use Make_Boolean_Array_Op)
-- and then inserting it into the tree. The original operator node is
-- then rewritten as a call to this function. We also use this in the
-- packed case if either operand is a possibly unaligned object.
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
Ensure_Defined (Etype (L), N);
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
if Nkind (Parent (N)) = N_Assignment_Statement
and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
then
Build_Boolean_Array_Proc_Call (Parent (N), L, R);
elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And
and then
Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
then
return;
else
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
-- Now rewrite the expression with a call
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations =>
New_List (
L,
Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
Analyze_And_Resolve (N, Typ);
end if;
end;
end Expand_Boolean_Operator;
-------------------------------
@ -4254,20 +4272,25 @@ package body Exp_Ch4 is
Force_Validity_Checks := Save_Force_Validity_Checks;
end;
-- Packed case
-- Packed case where both operands are known aligned
elsif Is_Bit_Packed_Array (Typl) then
elsif Is_Bit_Packed_Array (Typl)
and then not Is_Possibly_Unaligned_Object (Lhs)
and then not Is_Possibly_Unaligned_Object (Rhs)
then
Expand_Packed_Eq (N);
-- Where the component type is elementary we can use a block bit
-- comparison (if supported on the target) exception in the case
-- of floating-point (negative zero issues require element by
-- element comparison), and atomic types (where we must be sure
-- to load elements independently).
-- to load elements independently) and possibly unaligned arrays.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not Is_Atomic (Component_Type (Typl))
and then not Is_Possibly_Unaligned_Object (Lhs)
and then not Is_Possibly_Unaligned_Object (Rhs)
and then Support_Composite_Compare_On_Target
then
null;
@ -5278,9 +5301,13 @@ package body Exp_Ch4 is
return;
end if;
-- Case of array operand. If bit packed, handle it in Exp_Pakd
-- Case of array operand. If bit packed with a component size of 1,
-- handle it in Exp_Pakd if the operand is known to be aligned.
if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
if Is_Bit_Packed_Array (Typ)
and then Component_Size (Typ) = 1
and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
then
Expand_Packed_Not (N);
return;
end if;
@ -7984,7 +8011,8 @@ package body Exp_Ch4 is
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
Selector_Name =>
New_Reference_To (First_Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
return
@ -7992,14 +8020,17 @@ package body Exp_Ch4 is
Action => CW_Membership,
Args => New_List (
Obj_Tag,
New_Reference_To (
Access_Disp_Table (Root_Type (Right_Type)), Loc)));
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Root_Type (Right_Type)))),
Loc)));
else
return
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
New_Reference_To (Access_Disp_Table (Right_Type), Loc));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
end if;
end Tagged_Membership;

113
gcc/ada/exp_ch5.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -27,6 +27,7 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
@ -454,13 +455,13 @@ package body Exp_Ch5 is
end if;
end Check_Unconstrained_Bit_Packed_Array;
-- Gigi can always handle the assignment if the right side is a string
-- literal (note that overlap is definitely impossible in this case).
-- If the type is packed, a string literal is always converted into a
-- aggregate, except in the case of a null slice, for which no aggregate
-- can be written. In that case, rewrite the assignment as a null
-- statement, a length check has already been emitted to verify that
-- the range of the left-hand side is empty.
-- The back end can always handle the assignment if the right side is a
-- string literal (note that overlap is definitely impossible in this
-- case). If the type is packed, a string literal is always converted
-- into aggregate, except in the case of a null slice, for which no
-- aggregate can be written. In that case, rewrite the assignment as a
-- null statement, a length check has already been emitted to verify
-- that the range of the left-hand side is empty.
-- Note that this code is not executed if we had an assignment of
-- a string literal to a non-bit aligned component of a record, a
@ -479,7 +480,7 @@ package body Exp_Ch5 is
-- If either operand is bit packed, then we need a loop, since we
-- can't be sure that the slice is byte aligned. Similarly, if either
-- operand is a possibly unaligned slice, then we need a loop (since
-- gigi cannot handle unaligned slices).
-- the back end cannot handle unaligned slices).
elsif Is_Bit_Packed_Array (L_Type)
or else Is_Bit_Packed_Array (R_Type)
@ -490,7 +491,7 @@ package body Exp_Ch5 is
-- If we are not bit-packed, and we have only one slice, then no
-- overlap is possible except in the parameter case, so we can let
-- gigi handle things.
-- the back end handle things.
elsif not (L_Slice and R_Slice) then
if Forwards_OK (N) then
@ -641,7 +642,6 @@ package body Exp_Ch5 is
if not Loop_Required then
if Forwards_OK (N) then
return;
else
null;
-- Here is where a memmove would be appropriate ???
@ -843,7 +843,7 @@ package body Exp_Ch5 is
then
-- Call TSS procedure for array assignment, passing the
-- the explicit bounds of right- and left-hand side.
-- the explicit bounds of right and left hand sides.
declare
Proc : constant Node_Id :=
@ -999,13 +999,20 @@ package body Exp_Ch5 is
Make_Assignment_Statement (Loc,
Name =>
Make_Indexed_Component (Loc,
Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
Prefix => Duplicate_Subexpr (Larray, Name_Req => True),
Expressions => ExprL),
Expression =>
Make_Indexed_Component (Loc,
Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
Prefix => Duplicate_Subexpr (Rarray, Name_Req => True),
Expressions => ExprR));
-- We set assignment OK, since there are some cases, e.g. in object
-- declarations, where we are actually assigning into a constant.
-- If there really is an illegality, it was caught long before now,
-- and was flagged when the original assignment was analyzed.
Set_Assignment_OK (Name (Assign));
-- Propagate the No_Ctrl_Actions flag to individual assignments
Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
@ -1356,9 +1363,8 @@ package body Exp_Ch5 is
-- Expand_N_Assignment_Statement --
-----------------------------------
-- For array types, deal with slice assignments and setting the flags
-- to indicate if it can be statically determined which direction the
-- move should go in. Also deal with generating range/length checks.
-- This procedure implements various cases where an assignment statement
-- cannot just be passed on to the back end in untransformed state.
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@ -1469,7 +1475,8 @@ package body Exp_Ch5 is
declare
Uses_Transient_Scope : constant Boolean :=
Scope_Is_Transient and then N = Node_To_Be_Wrapped;
Scope_Is_Transient
and then N = Node_To_Be_Wrapped;
begin
if Uses_Transient_Scope then
@ -1647,8 +1654,6 @@ package body Exp_Ch5 is
Expand_Bit_Packed_Element_Set (N);
return;
-- Case of tagged type assignment
elsif Is_Tagged_Type (Typ)
or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ))
then
@ -1673,19 +1678,23 @@ package body Exp_Ch5 is
if Is_Class_Wide_Type (Typ)
-- If the type is tagged, we may as well use the predefined
-- primitive assignment. This avoids inlining a lot of code
-- and in the class-wide case, the assignment is replaced by
-- a dispatch call to _assign. Note that this cannot be done
-- when discriminant checks are locally suppressed (as in
-- extension aggregate expansions) because otherwise the
-- discriminant check will be performed within the _assign
-- call.
-- If the type is tagged, we may as well use the predefined
-- primitive assignment. This avoids inlining a lot of code
-- and in the class-wide case, the assignment is replaced by
-- dispatch call to _assign. Note that this cannot be done
-- when discriminant checks are locally suppressed (as in
-- extension aggregate expansions) because otherwise the
-- discriminant check will be performed within the _assign
-- call. It is also suppressed for assignmments created by the
-- expander that correspond to initializations, where we do
-- want to copy the tag (No_Ctrl_Actions flag set True).
-- by the expander and we do not need to mess with tags ever
-- (Expand_Ctrl_Actions flag is set True in this case).
or else (Is_Tagged_Type (Typ)
and then Chars (Current_Scope) /= Name_uAssign
and then Expand_Ctrl_Actions
and then not Discriminant_Checks_Suppressed (Empty))
or else (Is_Tagged_Type (Typ)
and then Chars (Current_Scope) /= Name_uAssign
and then Expand_Ctrl_Actions
and then not Discriminant_Checks_Suppressed (Empty))
then
-- Fetch the primitive op _assign and proper type to call
-- it. Because of possible conflits between private and
@ -1787,8 +1796,8 @@ package body Exp_Ch5 is
then
declare
Blk : constant Entity_Id :=
New_Internal_Entity (
E_Block, Current_Scope, Sloc (N), 'B');
New_Internal_Entity
(E_Block, Current_Scope, Sloc (N), 'B');
begin
Set_Scope (Blk, Current_Scope);
@ -2784,11 +2793,13 @@ package body Exp_Ch5 is
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
New_Reference_To (Tag_Component (Utyp), Loc)),
New_Reference_To (First_Tag_Component (Utyp), Loc)),
Right_Opnd =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Access_Disp_Table (Base_Type (Utyp)), Loc))),
(Node (First_Elmt
(Access_Disp_Table (Base_Type (Utyp)))),
Loc))),
Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type,
@ -3155,7 +3166,8 @@ package body Exp_Ch5 is
Expression =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc))));
Selector_Name => New_Reference_To (First_Tag_Component (T),
Loc))));
-- Otherwise Tag_Tmp not used
@ -3194,7 +3206,8 @@ package body Exp_Ch5 is
-- Index of first byte to be copied after outermost record
-- controller data.
Expr, Source_Size : Node_Id;
Expr, Source_Size : Node_Id;
Source_Actual_Subtype : Entity_Id;
-- Used for computation of the size of the data to be copied
Range_Type : Entity_Id;
@ -3269,26 +3282,27 @@ package body Exp_Ch5 is
Expr := Expression (Expr);
end if;
Source_Actual_Subtype := Etype (Expr);
if Has_Discriminants (Source_Actual_Subtype)
and then not Is_Constrained (Source_Actual_Subtype)
then
Append_To (Res,
Build_Actual_Subtype (Source_Actual_Subtype, Expr));
Source_Actual_Subtype := Defining_Identifier (Last (Res));
end if;
Source_Size :=
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
Expr,
New_Occurrence_Of (Source_Actual_Subtype, Loc),
Attribute_Name =>
Name_Size),
Right_Opnd =>
Make_Integer_Literal (Loc,
System_Storage_Unit - 1));
-- If Expr is a type conversion, standard Ada does not allow
-- 'Size to be taken on it, but Gigi can handle this case,
-- and thus we can determine the amount of data to be copied.
-- The appropriate circuitry is enabled only for conversions
-- that do not Come_From_Source.
Set_Comes_From_Source (Prefix (Left_Opnd (Source_Size)), False);
Source_Size :=
Make_Op_Divide (Loc,
Left_Opnd => Source_Size,
@ -3484,7 +3498,8 @@ package body Exp_Ch5 is
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc)),
Selector_Name => New_Reference_To (First_Tag_Component (T),
Loc)),
Expression => New_Reference_To (Tag_Tmp, Loc)));
end if;

17
gcc/ada/exp_ch9.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -162,7 +162,7 @@ package body Exp_Ch9 is
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected
-- subprogram. Its statement sequence first defers abortion, then locks
-- subprogram. Its statement sequence first defers abort, then locks
-- the associated protected object, and then enters a block that contains
-- a call to the unprotected version of the subprogram (for details, see
-- Build_Unprotected_Subprogram_Body). This block statement requires
@ -2531,10 +2531,9 @@ package body Exp_Ch9 is
-----------------------------------
function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (T);
Nam : constant Name_Id := Chars (T);
Tdec : constant Node_Id := Declaration_Node (T);
Ent : Entity_Id;
Loc : constant Source_Ptr := Sloc (T);
Nam : constant Name_Id := Chars (T);
Ent : Entity_Id;
begin
Ent :=
@ -2545,8 +2544,8 @@ package body Exp_Ch9 is
-- Associate the procedure with the task, if this is the declaration
-- (and not the body) of the procedure.
if No (Task_Body_Procedure (Tdec)) then
Set_Task_Body_Procedure (Tdec, Ent);
if No (Task_Body_Procedure (T)) then
Set_Task_Body_Procedure (T, Ent);
end if;
return
@ -4255,7 +4254,7 @@ package body Exp_Ch9 is
New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats));
-- Protected the call against abortion
-- Protected the call against abort
Prepend_To (Stmts,
Make_Procedure_Call_Statement (Loc,

45
gcc/ada/exp_disp.adb
View File

@ -288,7 +288,7 @@ package body Exp_Disp is
-- typ!(Displaced_This (Address!(Param)))
if Param = Ctrl_Arg
and then DTC_Entity (Subp) /= Tag_Component (Typ)
and then DTC_Entity (Subp) /= First_Tag_Component (Typ)
then
Append_To (New_Params,
@ -390,14 +390,16 @@ package body Exp_Disp is
Make_Selected_Component (Loc,
Prefix => New_Value (Ctrl_Arg),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
New_Reference_To
(First_Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Typ, New_Value (Param)),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc))),
New_Reference_To
(First_Tag_Component (Typ), Loc))),
Then_Statements =>
New_List (New_Constraint_Error (Loc))));
@ -545,7 +547,8 @@ package body Exp_Disp is
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc)),
New_Reference_To
(First_Tag_Component (Typ), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
@ -553,7 +556,8 @@ package body Exp_Disp is
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
New_Reference_To (Tag_Component (Typ), Loc))),
New_Reference_To
(First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
@ -579,7 +583,8 @@ package body Exp_Disp is
return Node_Id
is
Typ : constant Entity_Id := Scope (DTC_Entity (Prim));
DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ);
DT_Ptr : constant Entity_Id := Node (First_Elmt
(Access_Disp_Table (Typ)));
begin
return
@ -619,8 +624,9 @@ package body Exp_Disp is
function Make_DT (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Result : constant List_Id := New_List;
Elab_Code : constant List_Id := New_List;
ADT_List : constant Elist_Id := New_Elmt_List;
Result : constant List_Id := New_List;
Elab_Code : constant List_Id := New_List;
Tname : constant Name_Id := Chars (Typ);
Name_DT : constant Name_Id := New_External_Name (Tname, 'T');
@ -684,7 +690,7 @@ package body Exp_Disp is
Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
Right_Opnd =>
Make_Integer_Literal (Loc,
DT_Entry_Count (Tag_Component (Typ)))));
DT_Entry_Count (First_Tag_Component (Typ)))));
Append_To (Result,
Make_Object_Declaration (Loc,
@ -748,7 +754,8 @@ package body Exp_Disp is
-- Set Access_Disp_Table field to be the dispatch table pointer
Set_Access_Disp_Table (Typ, DT_Ptr);
Append_Elmt (DT_Ptr, ADT_List);
Set_Access_Disp_Table (Typ, ADT_List);
-- Count ancestors to compute the inheritance depth. For private
-- extensions, always go to the full view in order to compute the real
@ -840,12 +847,15 @@ package body Exp_Disp is
Make_Integer_Literal (Loc, 0));
else
Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc);
Old_Tag :=
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
Old_TSD :=
Make_DT_Access_Action (Typ,
Action => Get_TSD,
Args => New_List (
New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc)));
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc)));
end if;
-- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
@ -857,7 +867,7 @@ package body Exp_Disp is
Node1 => Old_Tag,
Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc,
DT_Entry_Count (Tag_Component (Etype (Typ)))))));
DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
-- Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
@ -1107,7 +1117,7 @@ package body Exp_Disp is
Parent_Typ : constant Entity_Id := Etype (Typ);
Root_Typ : constant Entity_Id := Root_Type (Typ);
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := Tag_Component (Typ);
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Parent_EC : Int;
@ -1120,9 +1130,10 @@ package body Exp_Disp is
-- Get Entry_Count of the parent
if Parent_Typ /= Typ
and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint
and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
then
Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ)));
Parent_EC := UI_To_Int (DT_Entry_Count
(First_Tag_Component (Parent_Typ)));
else
Parent_EC := 0;
end if;
@ -1327,7 +1338,7 @@ package body Exp_Disp is
pragma Assert (
DT_Entry_Count (The_Tag) >=
DT_Entry_Count (Tag_Component (Parent_Typ)));
DT_Entry_Count (First_Tag_Component (Parent_Typ)));
end if;
end Set_All_DT_Position;

81
gcc/ada/exp_dist.adb
View File

@ -266,7 +266,7 @@ package body Exp_Dist is
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : Name_Id);
TSS_Nam : TSS_Name_Type);
-- Create a renaming declaration of subprogram Nam,
-- and register it as a TSS for Typ with name TSS_Nam.
@ -1866,7 +1866,7 @@ package body Exp_Dist is
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
New_Occurrence_Of (Tag_Component
New_Occurrence_Of (First_Tag_Component
(Designated_Type (Etype (Pointer))), Loc)),
Expression =>
Make_Attribute_Reference (Loc,
@ -5467,7 +5467,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uFrom_Any);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
end Add_RACW_From_Any;
-----------------------------
@ -5781,7 +5781,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uTo_Any);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
end Add_RACW_To_Any;
-----------------------
@ -5855,7 +5855,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uTypeCode);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
end Add_RACW_TypeCode;
------------------------------
@ -6369,7 +6369,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uFrom_Any);
Set_Renaming_TSS (RAS_Type, Fnam, TSS_From_Any);
end Add_RAS_From_Any;
--------------------
@ -6461,7 +6461,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uTo_Any);
Set_Renaming_TSS (RAS_Type, Fnam, TSS_To_Any);
end Add_RAS_To_Any;
----------------------
@ -6550,7 +6550,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode);
Set_Renaming_TSS (RAS_Type, Fnam, TSS_TypeCode);
end Add_RAS_TypeCode;
-----------------------------------------
@ -8099,13 +8099,6 @@ package body Exp_Dist is
-- Local Subprograms --
-----------------------
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
-- A TSS reference for a representation aspect of a derived tagged
-- type must take into account inheritance of that aspect from
-- ancestor types. (copied from exp_attr.adb, should be shared???)
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id;
-- Given a numeric type Typ, return the smallest integer or floarting
@ -8236,7 +8229,7 @@ package body Exp_Dist is
-- First simple case where the From_Any function is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, Name_uFrom_Any);
Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
@ -8374,7 +8367,6 @@ package body Exp_Dist is
pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
@ -9017,7 +9009,7 @@ package body Exp_Dist is
-- First simple case where the To_Any function is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, Name_uTo_Any);
Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
-- Check first for Boolean and Character. These are enumeration
-- types, but we treat them specially, since they may require
@ -9686,7 +9678,7 @@ package body Exp_Dist is
-- First simple case where the TypeCode is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, Name_uTypeCode);
Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
if Present (Fnam) then
@ -10346,52 +10338,6 @@ package body Exp_Dist is
Statements => Stms));
end Build_TypeCode_Function;
------------------------
-- Find_Inherited_TSS --
------------------------
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
P_Type : Entity_Id := Typ;
Proc : Entity_Id;
begin
Proc := TSS (Base_Type (Typ), Nam);
-- Check first if there is a TSS given for the type itself
if Present (Proc) then
return Proc;
end if;
-- If Typ is a derived type, it may inherit attributes from some
-- ancestor which is not the ultimate underlying one. If Typ is a
-- derived tagged type, The corresponding primitive operation has
-- been created explicitly.
if Is_Derived_Type (P_Type) then
if Is_Tagged_Type (P_Type) then
return Find_Prim_Op (P_Type, Nam);
else
while Is_Derived_Type (P_Type) loop
Proc := TSS (Base_Type (Etype (Typ)), Nam);
if Present (Proc) then
return Proc;
else
P_Type := Base_Type (Etype (P_Type));
end if;
end loop;
end if;
end if;
-- If nothing else, use the TSS of the root type
return TSS (Base_Type (Underlying_Type (Typ)), Nam);
end Find_Inherited_TSS;
---------------------------------
-- Find_Numeric_Representation --
---------------------------------
@ -10634,7 +10580,6 @@ package body Exp_Dist is
Counter => Counter,
Datum => New_Occurrence_Of (Inner_Any, Loc));
Append_To (Stmts,
Make_Block_Statement (Loc,
Declarations =>
@ -10769,7 +10714,7 @@ package body Exp_Dist is
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : Name_Id)
TSS_Nam : TSS_Name_Type)
is
Loc : constant Source_Ptr := Sloc (Nam);
Spec : constant Node_Id := Parent (Nam);
@ -10779,7 +10724,7 @@ package body Exp_Dist is
Specification =>
Copy_Specification (Loc,
Spec => Spec,
New_Name => TSS_Nam),
New_Name => Make_TSS_Name (Typ, TSS_Nam)),
Name => New_Occurrence_Of (Nam, Loc));
Snam : constant Entity_Id :=

12
gcc/ada/par-ch11.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -190,6 +190,16 @@ package body Ch11 is
Set_Name (Raise_Node, P_Name);
end if;
if Token = Tok_With then
if Ada_Version < Ada_05 then
Error_Msg_SC ("string expression in raise is Ada 2005 extension");
Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
end if;
Scan; -- past WITH
Set_Expression (Raise_Node, P_Expression);
end if;
TF_Semicolon;
return Raise_Node;
end P_Raise_Statement;

123
gcc/ada/par-ch12.adb
View File

@ -487,13 +487,17 @@ package body Ch12 is
-- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
-- | FORMAL_ARRAY_TYPE_DEFINITION
-- | FORMAL_ACCESS_TYPE_DEFINITION
-- | FORMAL_INTERFACE_TYPE_DEFINITION
-- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
-- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
-- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION
function P_Formal_Type_Definition return Node_Id is
Scan_State : Saved_Scan_State;
Scan_State : Saved_Scan_State;
Typedef_Node : Node_Id;
begin
if Token_Name = Name_Abstract then
@ -524,38 +528,89 @@ package body Ch12 is
return P_Formal_Private_Type_Definition;
end if;
when Tok_Private | Tok_Limited | Tok_Tagged =>
return P_Formal_Private_Type_Definition;
when Tok_New =>
return P_Formal_Derived_Type_Definition;
when Tok_Left_Paren =>
return P_Formal_Discrete_Type_Definition;
when Tok_Range =>
return P_Formal_Signed_Integer_Type_Definition;
when Tok_Mod =>
return P_Formal_Modular_Type_Definition;
when Tok_Digits =>
return P_Formal_Floating_Point_Definition;
when Tok_Delta =>
return P_Formal_Fixed_Point_Definition;
when Tok_Access =>
return P_Access_Type_Definition;
when Tok_Array =>
return P_Array_Type_Definition;
when Tok_Access =>
return P_Access_Type_Definition;
when Tok_Delta =>
return P_Formal_Fixed_Point_Definition;
when Tok_Digits =>
return P_Formal_Floating_Point_Definition;
when Tok_Interface => -- Ada 2005 (AI-251)
return P_Interface_Type_Definition (Is_Synchronized => False);
when Tok_Left_Paren =>
return P_Formal_Discrete_Type_Definition;
when Tok_Limited =>
Save_Scan_State (Scan_State);
Scan; -- past LIMITED
if Token = Tok_Interface then
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => False);
Set_Limited_Present (Typedef_Node);
return Typedef_Node;
else
Restore_Scan_State (Scan_State);
return P_Formal_Private_Type_Definition;
end if;
when Tok_Mod =>
return P_Formal_Modular_Type_Definition;
when Tok_New =>
return P_Formal_Derived_Type_Definition;
when Tok_Private |
Tok_Tagged =>
return P_Formal_Private_Type_Definition;
when Tok_Range =>
return P_Formal_Signed_Integer_Type_Definition;
when Tok_Record =>
Error_Msg_SC ("record not allowed in generic type definition!");
Discard_Junk_Node (P_Record_Definition);
return Error;
-- Ada 2005 (AI-345)
when Tok_Protected |
Tok_Synchronized |
Tok_Task =>
Scan; -- past TASK, PROTECTED or SYNCHRONIZED
declare
Saved_Token : constant Token_Type := Token;
begin
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => True);
case Saved_Token is
when Tok_Task =>
Set_Task_Present (Typedef_Node);
when Tok_Protected =>
Set_Protected_Present (Typedef_Node);
when Tok_Synchronized =>
Set_Synchronized_Present (Typedef_Node);
when others =>
null;
end case;
return Typedef_Node;
end;
when others =>
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
@ -617,7 +672,7 @@ package body Ch12 is
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
-- [abstract] new SUBTYPE_MARK [with private]
-- [abstract] new SUBTYPE_MARK [[AND interface_list] with private]
-- The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
@ -638,6 +693,26 @@ package body Ch12 is
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
-- Ada 2005 (AI-251): Deal with interfaces
if Token = Tok_And then
Scan; -- past AND
if Ada_Version < Ada_05 then
Error_Msg_SP
("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Set_Interface_List (Def_Node, New_List);
loop
Append (P_Qualified_Simple_Name, Interface_List (Def_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
end if;
if Token = Tok_With then
Scan; -- past WITH
Set_Private_Present (Def_Node, True);

212
gcc/ada/par-ch3.adb
View File

@ -241,12 +241,16 @@ package body Ch3 is
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
-- | DERIVED_TYPE_DEFINITION
-- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
-- INTEGER_TYPE_DEFINITION ::=
-- SIGNED_INTEGER_TYPE_DEFINITION
-- MODULAR_TYPE_DEFINITION
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized ] interface
-- [AND interface_list]
-- Error recovery: can raise Error_Resync
-- Note: The processing for full type declaration, incomplete type
@ -256,18 +260,19 @@ package body Ch3 is
-- function handles only declarations starting with TYPE).
function P_Type_Declaration return Node_Id is
Abstract_Present : Boolean;
Abstract_Loc : Source_Ptr;
Decl_Node : Node_Id;
Discr_List : List_Id;
Discr_Sloc : Source_Ptr;
End_Labl : Node_Id;
Type_Loc : Source_Ptr;
Type_Start_Col : Column_Number;
Ident_Node : Node_Id;
Decl_Node : Node_Id;
Discr_List : List_Id;
Is_Derived_Iface : Boolean := False;
Unknown_Dis : Boolean;
Discr_Sloc : Source_Ptr;
Abstract_Present : Boolean;
Abstract_Loc : Source_Ptr;
End_Labl : Node_Id;
Typedef_Node : Node_Id;
Typedef_Node : Node_Id;
-- Normally holds type definition, except in the case of a private
-- extension declaration, in which case it holds the declaration itself
@ -551,12 +556,6 @@ package body Ch3 is
TF_Semicolon;
exit;
when Tok_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; -- past PRIVATE
TF_Semicolon;
exit;
when Tok_Limited =>
Scan; -- past LIMITED
@ -585,6 +584,18 @@ package body Ch3 is
Typedef_Node := P_Record_Definition;
Set_Limited_Present (Typedef_Node, True);
-- Ada 2005 (AI-251): LIMITED INTERFACE
elsif Token = Tok_Interface then
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => False);
Abstract_Present := True;
Set_Limited_Present (Typedef_Node);
if Nkind (Typedef_Node) = N_Derived_Type_Definition then
Is_Derived_Iface := True;
end if;
-- LIMITED PRIVATE is the only remaining possibility here
else
@ -634,6 +645,55 @@ package body Ch3 is
exit;
-- Ada 2005 (AI-251): INTERFACE
when Tok_Interface =>
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => False);
Abstract_Present := True;
TF_Semicolon;
exit;
when Tok_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; -- past PRIVATE
TF_Semicolon;
exit;
-- Ada 2005 (AI-345)
when Tok_Protected |
Tok_Synchronized |
Tok_Task =>
declare
Saved_Token : constant Token_Type := Token;
begin
Scan; -- past TASK, PROTECTED or SYNCHRONIZED
Typedef_Node := P_Interface_Type_Definition
(Is_Synchronized => True);
case Saved_Token is
when Tok_Task =>
Set_Task_Present (Typedef_Node);
when Tok_Protected =>
Set_Protected_Present (Typedef_Node);
when Tok_Synchronized =>
Set_Synchronized_Present (Typedef_Node);
when others =>
pragma Assert (False);
null;
end case;
end;
TF_Semicolon;
exit;
-- Anything else is an error
when others =>
@ -693,6 +753,7 @@ package body Ch3 is
if Nkind (Typedef_Node) = N_Record_Definition
or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node)))
or else Is_Derived_Iface
then
Set_Abstract_Present (Typedef_Node, Abstract_Present);
@ -1407,7 +1468,7 @@ package body Ch3 is
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
Error_Msg_SC ("RENAMES expected");
raise Error_Resync;
end if;
@ -1463,7 +1524,7 @@ package body Ch3 is
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
Error_Msg_SC ("RENAMES expected");
raise Error_Resync;
end if;
@ -1583,11 +1644,12 @@ package body Ch3 is
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [RECORD_EXTENSION_PART]
-- [[AND interface_list] RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
-- [abstract] new ancestor_SUBTYPE_INDICATION
-- [AND interface_list] with PRIVATE;
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
@ -1605,6 +1667,7 @@ package body Ch3 is
Typedef_Node : Node_Id;
Typedecl_Node : Node_Id;
Not_Null_Present : Boolean := False;
begin
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
T_New;
@ -1619,6 +1682,31 @@ package body Ch3 is
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
-- Ada 2005 (AI-251): Deal with interfaces
if Token = Tok_And then
Scan; -- past AND
if Ada_Version < Ada_05 then
Error_Msg_SP
("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Set_Interface_List (Typedef_Node, New_List);
loop
Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
if Token /= Tok_With then
Error_Msg_SC ("WITH expected");
raise Error_Resync;
end if;
end if;
-- Deal with record extension, note that we assume that a WITH is
-- missing in the case of "type X is new Y record ..." or in the
-- case of "type X is new Y null record".
@ -3279,6 +3367,94 @@ package body Ch3 is
-- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
--------------------------------------
-- 3.9.4 Interface Type Definition --
--------------------------------------
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized] interface
-- [AND interface_list]
-- Error recovery: cannot raise Error_Resync
function P_Interface_Type_Definition
(Is_Synchronized : Boolean) return Node_Id
is
Typedef_Node : Node_Id;
begin
if Ada_Version < Ada_05 then
Error_Msg_SP ("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Scan; -- past INTERFACE
-- Ada 2005 (AI-345): In case of synchronized interfaces and
-- interfaces with a null list of interfaces we build a
-- record_definition node.
if Is_Synchronized
or else Token = Tok_Semicolon
then
Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
Set_Abstract_Present (Typedef_Node);
Set_Tagged_Present (Typedef_Node);
Set_Null_Present (Typedef_Node);
Set_Interface_Present (Typedef_Node);
if Is_Synchronized
and then Token = Tok_And
then
Scan; -- past AND
Set_Interface_List (Typedef_Node, New_List);
loop
Append (P_Qualified_Simple_Name,
Interface_List (Typedef_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
end if;
-- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
-- a list of interfaces we build a derived_type_definition node. This
-- simplifies the semantic analysis (and hence further mainteinance)
else
if Token /= Tok_And then
Error_Msg_AP ("AND expected");
else
Scan; -- past AND
end if;
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
Set_Abstract_Present (Typedef_Node);
Set_Interface_Present (Typedef_Node);
Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
Set_Record_Extension_Part (Typedef_Node,
New_Node (N_Record_Definition, Token_Ptr));
Set_Null_Present (Record_Extension_Part (Typedef_Node));
if Token = Tok_And then
Set_Interface_List (Typedef_Node, New_List);
Scan; -- past AND
loop
Append (P_Qualified_Simple_Name,
Interface_List (Typedef_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
end if;
end if;
return Typedef_Node;
end P_Interface_Type_Definition;
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------

60
gcc/ada/par-ch9.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -53,7 +53,7 @@ package body Ch9 is
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
-- [is TASK_DEFINITION];
-- [is [new INTERFACE_LIST with] TASK_DEFINITION];
-- SINGLE_TASK_DECLARATION ::=
-- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
@ -161,6 +161,32 @@ package body Ch9 is
end if;
else
TF_Is; -- must have IS if no semicolon
-- Ada 2005 (AI-345)
if Token = Tok_New then
Scan; -- past NEW
if Ada_Version < Ada_05 then
Error_Msg_SP ("task interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Set_Interface_List (Task_Node, New_List);
loop
Append (P_Qualified_Simple_Name, Interface_List (Task_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
if Token /= Tok_With then
Error_Msg_SC ("WITH expected");
end if;
Scan; -- past WITH
end if;
Set_Task_Definition (Task_Node, P_Task_Definition);
end if;
@ -308,7 +334,7 @@ package body Ch9 is
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
-- is PROTECTED_DEFINITION;
-- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- SINGLE_PROTECTED_DECLARATION ::=
-- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
@ -402,6 +428,34 @@ package body Ch9 is
end if;
T_Is;
-- Ada 2005 (AI-345)
if Token = Tok_New then
Scan; -- past NEW
if Ada_Version < Ada_05 then
Error_Msg_SP ("task interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Set_Interface_List (Protected_Node, New_List);
loop
Append (P_Qualified_Simple_Name,
Interface_List (Protected_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
if Token /= Tok_With then
Error_Msg_SC ("WITH expected");
end if;
Scan; -- past WITH
end if;
Set_Protected_Definition (Protected_Node, P_Protected_Definition);
return Protected_Node;
end if;

13
gcc/ada/par.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -601,6 +601,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- treatment of errors in case a reserved word is scanned. See the
-- declaration of this type for details.
function P_Interface_Type_Definition
(Is_Synchronized : Boolean) return Node_Id;
-- Ada 2005 (AI-251): Parse the interface type definition part. The
-- parameter Is_Synchronized is True in case of task interfaces,
-- protected interfaces, and synchronized interfaces; it is used to
-- generate a record_definition node. In the rest of cases (limited
-- interfaces and interfaces) we generate a record_definition node if
-- the list of interfaces is empty; otherwise we generate a
-- derived_type_definition node (the first interface in this list is the
-- ancestor interface).
function P_Null_Exclusion return Boolean;
-- Ada 2005 (AI-231): Parse the null-excluding part. True indicates
-- that the null-excluding part was present.

8
gcc/ada/sem_ch11.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -363,7 +363,7 @@ package body Sem_Ch11 is
procedure Analyze_Raise_Statement (N : Node_Id) is
Exception_Id : constant Node_Id := Name (N);
Exception_Name : Entity_Id := Empty;
Exception_Name : Entity_Id := Empty;
P : Node_Id;
Nkind_P : Node_Kind;
@ -445,6 +445,10 @@ package body Sem_Ch11 is
Error_Msg_N
("exception name expected in raise statement", Exception_Id);
end if;
if Present (Expression (N)) then
Analyze_And_Resolve (Expression (N), Standard_String);
end if;
end if;
end Analyze_Raise_Statement;

8
gcc/ada/sem_prag.adb
View File

@ -5179,7 +5179,7 @@ package body Sem_Prag is
if Expander_Active and then Typ = Root_Type (Typ) then
Tag_C := Tag_Component (Typ);
Tag_C := First_Tag_Component (Typ);
C := First_Entity (Typ);
if C = Tag_C then
@ -5313,7 +5313,7 @@ package body Sem_Prag is
-- . DT_Position will be set at the freezing point
if Arg_Count = 1 then
Set_DTC_Entity (Subp, Tag_Component (Typ));
Set_DTC_Entity (Subp, First_Tag_Component (Typ));
return;
end if;
@ -5431,9 +5431,9 @@ package body Sem_Prag is
-- If it is the first pragma Vtable, This becomes the default tag
elsif (not Is_Tag (DTC))
and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
and then DT_Entry_Count (First_Tag_Component (Typ)) = No_Uint
then
Set_Is_Tag (Tag_Component (Typ), False);
Set_Is_Tag (First_Tag_Component (Typ), False);
Set_Is_Tag (DTC, True);
Set_DT_Entry_Count (DTC, No_Uint);
end if;

162
gcc/ada/sinfo.adb
View File

@ -314,8 +314,9 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Package_Declaration);
return Flag15 (N);
end Box_Present;
@ -628,7 +629,8 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
return Node2 (N);
end Default_Name;
@ -1056,7 +1058,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
return Flag11 (N);
return Flag7 (N);
end Exception_Junk;
function Expansion_Delayed
@ -1110,6 +1112,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
@ -1403,6 +1406,28 @@ package body Sinfo is
return Flag16 (N);
end Implicit_With;
function Interface_List
(N : Node_Id) return List_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Derived_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Task_Type_Declaration);
return List2 (N);
end Interface_List;
function Interface_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
return Flag16 (N);
end Interface_Present;
function In_Present
(N : Node_Id) return Boolean is
begin
@ -1639,6 +1664,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
@ -1865,7 +1891,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Subtype_Declaration);
return Flag9 (N);
return Flag11 (N);
end Null_Exclusion_Present;
function Null_Record_Present
@ -1885,14 +1911,6 @@ package body Sinfo is
return Node4 (N);
end Object_Definition;
function OK_For_Stream
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Attribute_Reference);
return Flag4 (N);
end OK_For_Stream;
function Original_Discriminant
(N : Node_Id) return Node_Id is
begin
@ -2121,8 +2139,10 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_Function_Definition
or else NT (N).Nkind = N_Access_Procedure_Definition);
return Flag15 (N);
or else NT (N).Nkind = N_Access_Procedure_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
return Flag6 (N);
end Protected_Present;
function Raises_Constraint_Error
@ -2296,14 +2316,15 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
return Node1 (N);
end Specification;
@ -2388,6 +2409,15 @@ package body Sinfo is
return List2 (N);
end Subtype_Marks;
function Synchronized_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
return Flag7 (N);
end Synchronized_Present;
function Tagged_Present
(N : Node_Id) return Boolean is
begin
@ -2407,14 +2437,6 @@ package body Sinfo is
return Node2 (N);
end Target_Type;
function Task_Body_Procedure
(N : Node_Id) return Entity_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Type_Declaration);
return Node2 (N);
end Task_Body_Procedure;
function Task_Definition
(N : Node_Id) return Node_Id is
begin
@ -2424,6 +2446,15 @@ package body Sinfo is
return Node3 (N);
end Task_Definition;
function Task_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
return Flag5 (N);
end Task_Present;
function Then_Actions
(N : Node_Id) return List_Id is
begin
@ -2816,8 +2847,9 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Package_Declaration);
Set_Flag15 (N, Val);
end Set_Box_Present;
@ -3130,7 +3162,8 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration);
Set_Node2_With_Parent (N, Val);
end Set_Default_Name;
@ -3549,7 +3582,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Label
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
Set_Flag11 (N, Val);
Set_Flag7 (N, Val);
end Set_Exception_Junk;
procedure Set_Expansion_Delayed
@ -3603,6 +3636,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Statement
or else NT (N).Nkind = N_Return_Statement
or else NT (N).Nkind = N_Type_Conversion
or else NT (N).Nkind = N_Unchecked_Expression
@ -3896,6 +3930,28 @@ package body Sinfo is
Set_Flag16 (N, Val);
end Set_Implicit_With;
procedure Set_Interface_List
(N : Node_Id; Val : List_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Derived_Type_Definition
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
or else NT (N).Nkind = N_Task_Type_Declaration);
Set_List2_With_Parent (N, Val);
end Set_Interface_List;
procedure Set_Interface_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
Set_Flag16 (N, Val);
end Set_Interface_Present;
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True) is
begin
@ -4132,6 +4188,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
@ -4358,7 +4415,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Subtype_Declaration);
Set_Flag9 (N, Val);
Set_Flag11 (N, Val);
end Set_Null_Exclusion_Present;
procedure Set_Null_Record_Present
@ -4378,14 +4435,6 @@ package body Sinfo is
Set_Node4_With_Parent (N, Val);
end Set_Object_Definition;
procedure Set_OK_For_Stream
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Attribute_Reference);
Set_Flag4 (N, Val);
end Set_OK_For_Stream;
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id) is
begin
@ -4614,8 +4663,10 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_Function_Definition
or else NT (N).Nkind = N_Access_Procedure_Definition);
Set_Flag15 (N, Val);
or else NT (N).Nkind = N_Access_Procedure_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
Set_Flag6 (N, Val);
end Set_Protected_Present;
procedure Set_Raises_Constraint_Error
@ -4789,14 +4840,15 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
or else NT (N).Nkind in N_Formal_Subprogram_Declaration);
or else NT (N).Nkind = N_Subprogram_Renaming_Declaration);
Set_Node1_With_Parent (N, Val);
end Set_Specification;
@ -4881,6 +4933,15 @@ package body Sinfo is
Set_List2_With_Parent (N, Val);
end Set_Subtype_Marks;
procedure Set_Synchronized_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
Set_Flag7 (N, Val);
end Set_Synchronized_Present;
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True) is
begin
@ -4900,14 +4961,6 @@ package body Sinfo is
Set_Node2 (N, Val); -- semantic field, no parent set
end Set_Target_Type;
procedure Set_Task_Body_Procedure
(N : Node_Id; Val : Entity_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Task_Type_Declaration);
Set_Node2 (N, Val); -- semantic field, no parent set
end Set_Task_Body_Procedure;
procedure Set_Task_Definition
(N : Node_Id; Val : Node_Id) is
begin
@ -4917,6 +4970,15 @@ package body Sinfo is
Set_Node3_With_Parent (N, Val);
end Set_Task_Definition;
procedure Set_Task_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Derived_Type_Definition
or else NT (N).Nkind = N_Record_Definition);
Set_Flag5 (N, Val);
end Set_Task_Present;
procedure Set_Then_Actions
(N : Node_Id; Val : List_Id) is
begin

245
gcc/ada/sinfo.ads
View File

@ -897,7 +897,7 @@ package Sinfo is
-- Note: if the Is_Overloaded flag is set, then Etype points to
-- an essentially arbitrary choice from the possible set of types.
-- Exception_Junk (Flag11-Sem)
-- Exception_Junk (Flag7-Sem)
-- This flag is set in a various nodes appearing in a statement
-- sequence to indicate that the corresponding node is an artifact
-- of the generated code for exception handling, and should be
@ -1317,16 +1317,6 @@ package Sinfo is
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
-- OK_For_Stream (Flag4-Sem)
-- Present in N_Attribute_Definition clauses for stream attributes. If
-- set, indicates that the attribute is permitted even though the type
-- involved is a limited type. In the case of a protected type, the
-- result is to stream all components (including discriminants) in
-- lexical order. For other limited types, the effect is simply to
-- use the corresponding stream routine for the full type. This flag
-- is used for internally generated code, where the streaming of these
-- types is required, even though not normally allowed by the language.
-- Original_Discriminant (Node2-Sem)
-- Present in identifiers. Used in references to discriminants that
-- appear in generic units. Because the names of the discriminants
@ -1430,7 +1420,7 @@ package Sinfo is
-- be rounded to the nearest integer (breaking ties away from zero),
-- rather than truncated towards zero as usual. These rounded integer
-- operations are the result of expansion of rounded fixed-point
-- divide, conersion and multiplication operations.
-- divide, conversion and multiplication operations.
-- Scope (Node3-Sem)
-- Present in defining identifiers, defining character literals and
@ -1477,12 +1467,6 @@ package Sinfo is
-- target type entity for the unchecked conversion instantiation
-- which gigi must do size validation for.
-- Task_Body_Procedure (Node2-Sem)
-- Present in task type declaration nodes. Points to the entity for
-- the task body procedure (as further described in Exp_Ch9, task
-- bodies are expanded into procedures). A convenient function to
-- retrieve this field is Sem_Util.Get_Task_Body_Procedure.
-- Then_Actions (List3-Sem)
-- This field is present in conditional expression nodes. During code
-- expansion we use the Insert_Actions procedure (in Exp_Util) to insert
@ -1888,7 +1872,7 @@ package Sinfo is
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
-- | DERIVED_TYPE_DEFINITION
-- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
--------------------------------
-- 3.2.2 Subtype Declaration --
@ -1903,10 +1887,10 @@ package Sinfo is
-- N_Subtype_Declaration
-- Sloc points to SUBTYPE
-- Defining_Identifier (Node1)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-- Exception_Junk (Flag11-Sem)
-- Exception_Junk (Flag7-Sem)
-------------------------------
-- 3.2.2 Subtype Indication --
@ -2015,7 +1999,7 @@ package Sinfo is
-- Defining_Identifier (Node1)
-- Aliased_Present (Flag4) set if ALIASED appears
-- Constant_Present (Flag17) set if CONSTANT appears
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Object_Definition (Node4) subtype indication/array type definition
-- Expression (Node3) (set to Empty if not present)
-- Handler_List_Entry (Node2-Sem)
@ -2024,7 +2008,7 @@ package Sinfo is
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
-- No_Initialization (Flag13-Sem)
-- Assignment_OK (Flag15-Sem)
-- Exception_Junk (Flag11-Sem)
-- Exception_Junk (Flag7-Sem)
-- Delay_Finalize_Attach (Flag14-Sem)
-- Is_Subprogram_Descriptor (Flag16-Sem)
@ -2063,7 +2047,7 @@ package Sinfo is
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [RECORD_EXTENSION_PART]
-- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- Note: ABSTRACT, record extension part not permitted in Ada 83 mode
@ -2072,9 +2056,20 @@ package Sinfo is
-- N_Derived_Type_Definition
-- Sloc points to NEW
-- Abstract_Present (Flag4)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11) (set to False if not present)
-- Subtype_Indication (Node5)
-- Record_Extension_Part (Node3) (set to Empty if not present)
-- Limited_Present (Flag17) set in interfaces
-- Task_Present (Flag5) set in task interfaces
-- Protected_Present (Flag6) set in protected interfaces
-- Synchronized_Present (Flag7) set in interfaces
-- Interface_List (List2) (set to No_List if none)
-- Interface_Present (Flag16) set in abstract interfaces
-- Note: The attributes Limited_Present, Task_Present, Protected_Present
-- Synchronized_Present, Interface_List and Interface_Present are
-- used for abstract interfaces (see comment in the definition
-- of INTERFACE_TYPE_DEFINITION)
---------------------------
-- 3.5 Range Constraint --
@ -2364,7 +2359,7 @@ package Sinfo is
-- N_Component_Definition
-- Sloc points to ALIASED, ACCESS or to first token of subtype mark
-- Aliased_Present (Flag4)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5) (set to Empty if not present)
-- Access_Definition (Node3) (set to Empty if not present)
@ -2437,9 +2432,8 @@ package Sinfo is
-- N_Discriminant_Specification
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Discriminant_Type (Node5) subtype mark or
-- access parameter definition
-- Null_Exclusion_Present (Flag11)
-- Discriminant_Type (Node5) subtype mark or access parameter definition
-- Expression (Node3) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
@ -2525,6 +2519,16 @@ package Sinfo is
-- Limited_Present (Flag17)
-- Component_List (Node1) empty in null record case
-- Null_Present (Flag13) set in null record case
-- Task_Present (Flag5) set in task interfaces
-- Protected_Present (Flag6) set in protected interfaces
-- Synchronized_Present (Flag7) set in interfaces
-- Interface_Present (Flag16) set in abstract interfaces
-- Interface_List (List2) (set to No_List if none)
-- Note: The attributes Task_Present, Protected_Present, Synchronized
-- _Present, Interface_List and Interface_Present are
-- used for abstract interfaces (see comment in the definition
-- of INTERFACE_TYPE_DEFINITION)
-------------------------
-- 3.8 Component List --
@ -2651,6 +2655,19 @@ package Sinfo is
-- Note: record extension parts are not permitted in Ada 83 mode
--------------------------------------
-- 3.9.4 Interface Type Definition --
--------------------------------------
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized]
-- interface [interface_list]
-- Note: Interfaces are implemented with N_Record_Definition and
-- N_Derived_Type_Definition nodes because most of the support
-- for the analysis of abstract types has been reused to
-- analyze abstract interfaces.
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------
@ -2676,7 +2693,7 @@ package Sinfo is
-- N_Access_To_Object_Definition
-- Sloc points to ACCESS
-- All_Present (Flag15)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5)
-- Constant_Present (Flag17)
@ -2705,15 +2722,15 @@ package Sinfo is
-- N_Access_Function_Definition
-- Sloc points to ACCESS
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Protected_Present (Flag15)
-- Null_Exclusion_Present (Flag11)
-- Protected_Present (Flag6)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Subtype_Mark (Node4) result subtype
-- N_Access_Procedure_Definition
-- Sloc points to ACCESS
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Protected_Present (Flag15)
-- Null_Exclusion_Present (Flag11)
-- Protected_Present (Flag6)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-----------------------------
@ -2728,7 +2745,7 @@ package Sinfo is
-- N_Access_Definition
-- Sloc points to ACCESS
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- All_Present (Flag15)
-- Constant_Present (Flag17)
-- Subtype_Mark (Node4)
@ -2933,11 +2950,11 @@ package Sinfo is
-- i.e. digits, access, delta, range, the Attribute_Name field contains
-- the corresponding name, even though no identifier is involved.
-- The flag OK_For_Stream is used in generated code to indicate that
-- a stream attribute is permissible for a limited type, and results
-- in the use of the stream attribute for the underlying full type,
-- or in the case of a protected type, the components (including any
-- disriminants) are merely streamed in order.
-- Note: the generated code may contain stream attributes applied to
-- limited types for which no stream routines exist officially. In such
-- case, the result is to use the stream attribute for the underlying
-- full type, or in the case of a protected type, the components
-- (including any disriminants) are merely streamed in order.
-- See Exp_Attr for a complete description of which attributes are
-- passed onto Gigi, and which are handled entirely by the front end.
@ -2964,7 +2981,6 @@ package Sinfo is
-- Associated_Node (Node4-Sem)
-- Do_Overflow_Check (Flag17-Sem)
-- Redundant_Use (Flag13-Sem)
-- OK_For_Stream (Flag4-Sem)
-- Must_Be_Byte_Aligned (Flag14)
-- plus fields for expression
@ -3529,7 +3545,7 @@ package Sinfo is
-- N_Allocator
-- Sloc points to NEW
-- Expression (Node3) subtype indication or qualified expression
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Storage_Pool (Node1-Sem)
-- Procedure_To_Call (Node4-Sem)
-- No_Initialization (Flag13-Sem)
@ -3606,7 +3622,7 @@ package Sinfo is
-- N_Label
-- Sloc points to <<
-- Identifier (Node1) direct name of statement identifier
-- Exception_Junk (Flag11-Sem)
-- Exception_Junk (Flag7-Sem)
-------------------------------
-- 5.1 Statement Identifier --
@ -3846,7 +3862,7 @@ package Sinfo is
-- N_Goto_Statement
-- Sloc points to GOTO
-- Name (Node2)
-- Exception_Junk (Flag11-Sem)
-- Exception_Junk (Flag7-Sem)
---------------------------------
-- 6.1 Subprogram Declaration --
@ -4044,7 +4060,7 @@ package Sinfo is
-- Defining_Identifier (Node1)
-- In_Present (Flag15)
-- Out_Present (Flag17)
-- Null_Exclusion_Present (Flag9) (set to False if not present)
-- Null_Exclusion_Present (Flag11)
-- Parameter_Type (Node2) subtype mark or access definition
-- Expression (Node3) (set to Empty if no default expression present)
-- Do_Accessibility_Check (Flag13-Sem)
@ -4283,7 +4299,8 @@ package Sinfo is
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] new ancestor_SUBTYPE_INDICATION with private;
-- [abstract] new ancestor_SUBTYPE_INDICATION
-- [and INTERFACE_LIST] with private;
-- Note: private extension declarations are not allowed in Ada 83 mode
@ -4295,6 +4312,7 @@ package Sinfo is
-- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
-- Abstract_Present (Flag4)
-- Subtype_Indication (Node5)
-- Interface_List (List2) (set to No_List if none)
---------------------
-- 8.4 Use Clause --
@ -4436,14 +4454,14 @@ package Sinfo is
-- TASK_TYPE_DECLARATION ::=
-- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
-- [is TASK_DEFINITITION];
-- [is [new INTERFACE_LIST with] TASK_DEFINITITION];
-- N_Task_Type_Declaration
-- Sloc points to TASK
-- Defining_Identifier (Node1)
-- Task_Body_Procedure (Node2-Sem)
-- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part)
-- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
-- Corresponding_Body (Node5-Sem)
@ -4517,7 +4535,7 @@ package Sinfo is
-- PROTECTED_TYPE_DECLARATION ::=
-- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
-- is PROTECTED_DEFINITION;
-- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: protected type declarations are not permitted in Ada 83 mode
@ -4526,6 +4544,7 @@ package Sinfo is
-- Defining_Identifier (Node1)
-- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part)
-- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
-- Corresponding_Body (Node5-Sem)
@ -5393,9 +5412,14 @@ package Sinfo is
-- RAISE_STATEMENT ::= raise [exception_NAME];
-- In Ada 2005, we have
-- RAISE_STATEMENT ::= raise; | raise exception_NAME [with EXPRESSION];
-- N_Raise_Statement
-- Sloc points to RAISE
-- Name (Node2) (set to Empty if no exception name present)
-- Expression (Node3) (set to Empty if no expression present)
-------------------------------
-- 12.1 Generic Declaration --
@ -5591,6 +5615,7 @@ package Sinfo is
-- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
-- | FORMAL_ARRAY_TYPE_DEFINITION
-- | FORMAL_ACCESS_TYPE_DEFINITION
-- | FORMAL_INTERFACE_TYPE_DEFINITION
---------------------------------------------
-- 12.5.1 Formal Private Type Definition --
@ -5612,8 +5637,7 @@ package Sinfo is
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
-- [abstract] new SUBTYPE_MARK [with private]
-- [abstract] new SUBTYPE_MARK [[and INTERFACE_LIST] with private]
-- Note: this construct is not allowed in Ada 83 mode
-- N_Formal_Derived_Type_Definition
@ -5621,6 +5645,7 @@ package Sinfo is
-- Subtype_Mark (Node4)
-- Private_Present (Flag15)
-- Abstract_Present (Flag4)
-- Interface_List (List2) (set to No_List if none)
---------------------------------------------
-- 12.5.2 Formal Discrete Type Definition --
@ -5690,6 +5715,12 @@ package Sinfo is
-- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
----------------------------------------------
-- 12.5.5 Formal Interface Type Definition --
----------------------------------------------
-- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION
-----------------------------------------
-- 12.6 Formal Subprogram Declaration --
-----------------------------------------
@ -6503,6 +6534,7 @@ package Sinfo is
N_Unused_At_Start,
-- N_Representation_Clause
N_At_Clause,
N_Component_Clause,
N_Enumeration_Representation_Clause,
@ -6510,35 +6542,43 @@ package Sinfo is
N_Record_Representation_Clause,
-- N_Representation_Clause, N_Has_Chars
N_Attribute_Definition_Clause,
-- N_Has_Chars
N_Empty,
N_Pragma,
N_Pragma_Argument_Association,
-- N_Has_Etype
N_Error,
-- N_Entity, N_Has_Etype, N_Has_Chars
N_Defining_Character_Literal,
N_Defining_Identifier,
N_Defining_Operator_Symbol,
-- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Has_Entity
N_Expanded_Name,
-- N_Direct_Name, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
N_Identifier,
N_Operator_Symbol,
-- N_Direct_Name, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
N_Character_Literal,
-- N_Binary_Op, N_Op, N_Subexpr,
-- N_Has_Etype, N_Has_Chars, N_Has_Entity
N_Op_Add,
N_Op_Concat,
N_Op_Expon,
@ -6554,11 +6594,12 @@ package Sinfo is
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean
N_Op_And,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean,
-- N_Op_Compare
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean, N_Op_Compare
N_Op_Eq,
N_Op_Ge,
N_Op_Gt,
@ -6568,11 +6609,13 @@ package Sinfo is
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean
N_Op_Or,
N_Op_Xor,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype,
-- N_Op_Shift, N_Has_Chars, N_Has_Entity
N_Op_Rotate_Left,
N_Op_Rotate_Right,
N_Op_Shift_Left,
@ -6581,15 +6624,18 @@ package Sinfo is
-- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype,
-- N_Has_Chars, N_Has_Entity
N_Op_Abs,
N_Op_Minus,
N_Op_Not,
N_Op_Plus,
-- N_Subexpr, N_Has_Etype, N_Has_Entity
N_Attribute_Reference,
-- N_Subexpr, N_Has_Etype
N_And_Then,
N_Conditional_Expression,
N_Explicit_Dereference,
@ -6626,9 +6672,11 @@ package Sinfo is
N_Unchecked_Type_Conversion,
-- N_Has_Etype
N_Subtype_Indication,
-- N_Declaration
N_Component_Declaration,
N_Entry_Declaration,
N_Formal_Object_Declaration,
@ -6643,40 +6691,44 @@ package Sinfo is
N_Subtype_Declaration,
-- N_Subprogram_Specification, N_Declaration
N_Function_Specification,
N_Procedure_Specification,
-- (nothing special)
N_Entry_Index_Specification,
N_Freeze_Entity,
-- N_Access_To_Subprogram_Definition
N_Access_Function_Definition,
N_Access_Procedure_Definition,
-- N_Later_Decl_Item,
-- N_Later_Decl_Item
N_Task_Type_Declaration,
-- N_Body_Stub, N_Later_Decl_Item
N_Package_Body_Stub,
N_Protected_Body_Stub,
N_Subprogram_Body_Stub,
N_Task_Body_Stub,
-- N_Generic_Instantiation, N_Later_Decl_Item
N_Function_Instantiation,
N_Package_Instantiation,
N_Procedure_Instantiation,
-- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body
N_Package_Body,
N_Subprogram_Body,
-- N_Later_Decl_Item, N_Proper_Body
N_Protected_Body,
N_Task_Body,
-- N_Later_Decl_Item
N_Implicit_Label_Declaration,
N_Package_Declaration,
N_Single_Task_Declaration,
@ -6684,25 +6736,30 @@ package Sinfo is
N_Use_Package_Clause,
-- N_Generic_Declaration, N_Later_Decl_Item
N_Generic_Package_Declaration,
N_Generic_Subprogram_Declaration,
-- N_Array_Type_Definition
N_Constrained_Array_Definition,
N_Unconstrained_Array_Definition,
-- N_Renaming_Declaration
N_Exception_Renaming_Declaration,
N_Object_Renaming_Declaration,
N_Package_Renaming_Declaration,
N_Subprogram_Renaming_Declaration,
-- N_Generic_Renaming_Declarations, N_Renaming_Declaration
N_Generic_Function_Renaming_Declaration,
N_Generic_Package_Renaming_Declaration,
N_Generic_Procedure_Renaming_Declaration,
-- N_Statement_Other_Than_Procedure_Call
N_Abort_Statement,
N_Accept_Statement,
N_Assignment_Statement,
@ -6725,10 +6782,12 @@ package Sinfo is
N_Timed_Entry_Call,
-- N_Statement_Other_Than_Procedure_Call, N_Has_Condition
N_Exit_Statement,
N_If_Statement,
-- N_Has_Condition
N_Accept_Alternative,
N_Delay_Alternative,
N_Elsif_Part,
@ -6736,7 +6795,13 @@ package Sinfo is
N_Iteration_Scheme,
N_Terminate_Alternative,
-- N_Formal_Subprogram_Declaration
N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Concrete_Subprogram_Declaration,
-- Other nodes (not part of any subtype class)
N_Abortable_Part,
N_Abstract_Subprogram_Declaration,
N_Access_Definition,
@ -6758,11 +6823,10 @@ package Sinfo is
N_Enumeration_Type_Definition,
N_Entry_Body,
N_Entry_Call_Alternative,
N_Entry_Index_Specification,
N_Exception_Declaration,
N_Exception_Handler,
N_Floating_Point_Definition,
N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Concrete_Subprogram_Declaration,
N_Formal_Decimal_Fixed_Point_Definition,
N_Formal_Derived_Type_Definition,
N_Formal_Discrete_Type_Definition,
@ -6772,6 +6836,7 @@ package Sinfo is
N_Formal_Package_Declaration,
N_Formal_Private_Type_Definition,
N_Formal_Signed_Integer_Type_Definition,
N_Freeze_Entity,
N_Generic_Association,
N_Handled_Sequence_Of_Statements,
N_Index_Or_Discriminant_Constraint,
@ -7276,7 +7341,7 @@ package Sinfo is
(N : Node_Id) return List_Id; -- List5
function Exception_Junk
(N : Node_Id) return Boolean; -- Flag11
(N : Node_Id) return Boolean; -- Flag7
function Explicit_Actual_Parameter
(N : Node_Id) return Node_Id; -- Node3
@ -7383,6 +7448,12 @@ package Sinfo is
function Identifier
(N : Node_Id) return Node_Id; -- Node1
function Interface_List
(N : Node_Id) return List_Id; -- List2
function Interface_Present
(N : Node_Id) return Boolean; -- Flag16
function Implicit_With
(N : Node_Id) return Boolean; -- Flag16
@ -7531,7 +7602,7 @@ package Sinfo is
(N : Node_Id) return Boolean; -- Flag13
function Null_Exclusion_Present
(N : Node_Id) return Boolean; -- Flag9
(N : Node_Id) return Boolean; -- Flag11
function Null_Record_Present
(N : Node_Id) return Boolean; -- Flag17
@ -7539,9 +7610,6 @@ package Sinfo is
function Object_Definition
(N : Node_Id) return Node_Id; -- Node4
function OK_For_Stream
(N : Node_Id) return Boolean; -- Flag4
function Original_Discriminant
(N : Node_Id) return Node_Id; -- Node2
@ -7609,7 +7677,7 @@ package Sinfo is
(N : Node_Id) return Node_Id; -- Node3
function Protected_Present
(N : Node_Id) return Boolean; -- Flag15
(N : Node_Id) return Boolean; -- Flag6
function Raises_Constraint_Error
(N : Node_Id) return Boolean; -- Flag7
@ -7689,18 +7757,21 @@ package Sinfo is
function Subtype_Marks
(N : Node_Id) return List_Id; -- List2
function Synchronized_Present
(N : Node_Id) return Boolean; -- Flag7
function Tagged_Present
(N : Node_Id) return Boolean; -- Flag15
function Target_Type
(N : Node_Id) return Entity_Id; -- Node2
function Task_Body_Procedure
(N : Node_Id) return Entity_Id; -- Node2
function Task_Definition
(N : Node_Id) return Node_Id; -- Node3
function Task_Present
(N : Node_Id) return Boolean; -- Flag5
function Then_Actions
(N : Node_Id) return List_Id; -- List2
@ -8071,7 +8142,7 @@ package Sinfo is
(N : Node_Id; Val : List_Id); -- List5
procedure Set_Exception_Junk
(N : Node_Id; Val : Boolean := True); -- Flag11
(N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Expansion_Delayed
(N : Node_Id; Val : Boolean := True); -- Flag11
@ -8178,6 +8249,12 @@ package Sinfo is
procedure Set_Identifier
(N : Node_Id; Val : Node_Id); -- Node1
procedure Set_Interface_List
(N : Node_Id; Val : List_Id); -- List2
procedure Set_Interface_Present
(N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_Implicit_With
(N : Node_Id; Val : Boolean := True); -- Flag16
@ -8326,7 +8403,7 @@ package Sinfo is
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Null_Exclusion_Present
(N : Node_Id; Val : Boolean := True); -- Flag9
(N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Null_Record_Present
(N : Node_Id; Val : Boolean := True); -- Flag17
@ -8334,9 +8411,6 @@ package Sinfo is
procedure Set_Object_Definition
(N : Node_Id; Val : Node_Id); -- Node4
procedure Set_OK_For_Stream
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id); -- Node2
@ -8404,7 +8478,7 @@ package Sinfo is
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Protected_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Raises_Constraint_Error
(N : Node_Id; Val : Boolean := True); -- Flag7
@ -8484,18 +8558,21 @@ package Sinfo is
procedure Set_Subtype_Marks
(N : Node_Id; Val : List_Id); -- List2
procedure Set_Synchronized_Present
(N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id); -- Node2
procedure Set_Task_Body_Procedure
(N : Node_Id; Val : Entity_Id); -- Node2
procedure Set_Task_Definition
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Task_Present
(N : Node_Id; Val : Boolean := True); -- Flag5
procedure Set_Then_Actions
(N : Node_Id; Val : List_Id); -- List2
@ -8713,6 +8790,8 @@ package Sinfo is
pragma Inline (High_Bound);
pragma Inline (Identifier);
pragma Inline (Implicit_With);
pragma Inline (Interface_List);
pragma Inline (Interface_Present);
pragma Inline (Includes_Infinities);
pragma Inline (In_Present);
pragma Inline (Instance_Spec);
@ -8764,7 +8843,6 @@ package Sinfo is
pragma Inline (Null_Exclusion_Present);
pragma Inline (Null_Record_Present);
pragma Inline (Object_Definition);
pragma Inline (OK_For_Stream);
pragma Inline (Original_Discriminant);
pragma Inline (Original_Entity);
pragma Inline (Others_Discrete_Choices);
@ -8814,10 +8892,11 @@ package Sinfo is
pragma Inline (Subtype_Indication);
pragma Inline (Subtype_Mark);
pragma Inline (Subtype_Marks);
pragma Inline (Synchronized_Present);
pragma Inline (Tagged_Present);
pragma Inline (Target_Type);
pragma Inline (Task_Body_Procedure);
pragma Inline (Task_Definition);
pragma Inline (Task_Present);
pragma Inline (Then_Actions);
pragma Inline (Then_Statements);
pragma Inline (Triggering_Alternative);
@ -8976,6 +9055,8 @@ package Sinfo is
pragma Inline (Set_Identifier);
pragma Inline (Set_Implicit_With);
pragma Inline (Set_Includes_Infinities);
pragma Inline (Set_Interface_List);
pragma Inline (Set_Interface_Present);
pragma Inline (Set_In_Present);
pragma Inline (Set_Instance_Spec);
pragma Inline (Set_Intval);
@ -9025,7 +9106,6 @@ package Sinfo is
pragma Inline (Set_Null_Exclusion_Present);
pragma Inline (Set_Null_Record_Present);
pragma Inline (Set_Object_Definition);
pragma Inline (Set_OK_For_Stream);
pragma Inline (Set_Original_Discriminant);
pragma Inline (Set_Original_Entity);
pragma Inline (Set_Others_Discrete_Choices);
@ -9075,10 +9155,11 @@ package Sinfo is
pragma Inline (Set_Subtype_Indication);
pragma Inline (Set_Subtype_Mark);
pragma Inline (Set_Subtype_Marks);
pragma Inline (Set_Synchronized_Present);
pragma Inline (Set_Tagged_Present);
pragma Inline (Set_Target_Type);
pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Task_Definition);
pragma Inline (Set_Task_Present);
pragma Inline (Set_Then_Actions);
pragma Inline (Set_Then_Statements);
pragma Inline (Set_Triggering_Alternative);

22
gcc/ada/tbuild.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -26,6 +26,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
@ -169,11 +170,12 @@ package body Tbuild is
return
Unchecked_Convert_To (
New_Occurrence_Of (Etype (Access_Disp_Table (Full_Type)), Loc),
New_Occurrence_Of
(Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
Make_Selected_Component (Loc,
Prefix => New_Copy (Rec),
Selector_Name =>
New_Reference_To (Tag_Component (Full_Type), Loc)));
New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
-----------------------
@ -183,9 +185,9 @@ package body Tbuild is
function Make_DT_Component
(Loc : Source_Ptr;
Typ : Entity_Id;
I : Positive) return Node_Id
N : Positive) return Node_Id
is
X : Node_Id;
X : Node_Id;
Full_Type : Entity_Id := Typ;
begin
@ -193,10 +195,12 @@ package body Tbuild is
Full_Type := Underlying_Type (Typ);
end if;
X := First_Component (
Designated_Type (Etype (Access_Disp_Table (Full_Type))));
X :=
First_Component
(Designated_Type
(Etype (Node (First_Elmt (Access_Disp_Table (Full_Type))))));
for J in 2 .. I loop
for J in 2 .. N loop
X := Next_Component (X);
end loop;
@ -216,6 +220,7 @@ package body Tbuild is
is
begin
Check_Restriction (No_Implicit_Conditionals, Node);
return Make_If_Statement (Sloc (Node),
Condition,
Then_Statements,
@ -234,7 +239,6 @@ package body Tbuild is
is
N : constant Node_Id :=
Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
begin
Set_Label_Construct (N, Label_Construct);
return N;