diff options
| -rw-r--r-- | gcc/ada/atree.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 152 | ||||
| -rw-r--r-- | gcc/ada/atree.h | 4 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 136 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 96 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 47 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 342 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 157 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 115 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/exp_dist.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/par-ch11.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/par-ch12.adb | 109 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 212 | ||||
| -rw-r--r-- | gcc/ada/par-ch9.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch11.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 162 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 245 | ||||
| -rw-r--r-- | gcc/ada/tbuild.adb | 22 |
25 files changed, 1437 insertions, 727 deletions
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 8122d85068c..f2266343971 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -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); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 8b08b524a1f..309310487c5 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -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. - - -- 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. + -- 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. + + -- 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 - - -- 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 + -- Field5 Five fields holding Union_Id values + + -- 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 diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 0d06969467e..c878a125afc 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -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) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8606bf0958a..900b69a7e2b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -129,7 +129,7 @@ package body Einfo is -- String_Literal_Low_Bound Node15 -- Shared_Var_Read_Proc Node15 - -- Access_Disp_Table Node16 + -- Access_Disp_Table Elist16 -- Cloned_Subtype Node16 -- DTC_Entity Node16 -- Entry_Formal Node16 @@ -210,9 +210,13 @@ package body Einfo is -- Protected_Operation Node23 -- Obsolescent_Warning Node24 + -- Task_Body_Procedure Node24 + -- Abstract_Interfaces Node24 + + -- Abstract_Interface_Alias Node25 - -- (unused) Node25 -- (unused) Node26 + -- (unused) Node27 --------------------------------------------- @@ -428,8 +432,8 @@ package body Einfo is -- Must_Be_On_Byte_Boundary Flag183 -- Has_Stream_Size_Clause Flag184 -- Is_Ada_2005 Flag185 + -- Is_Interface Flag186 - -- (unused) Flag186 -- (unused) Flag187 -- (unused) Flag188 -- (unused) Flag189 @@ -494,15 +498,31 @@ package body Einfo is -- Attribute Access Functions -- -------------------------------- + function Abstract_Interfaces (Id : E) return L is + begin + pragma Assert (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private); + return Elist24 (Id); + end Abstract_Interfaces; + + function Abstract_Interface_Alias (Id : E) return E is + begin + pragma Assert + (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function); + return Node25 (Id); + end Abstract_Interface_Alias; + function Accept_Address (Id : E) return L is begin return Elist21 (Id); end Accept_Address; - function Access_Disp_Table (Id : E) return E is + function Access_Disp_Table (Id : E) return L is begin pragma Assert (Is_Tagged_Type (Id)); - return Node16 (Implementation_Base_Type (Id)); + return Elist16 (Implementation_Base_Type (Id)); end Access_Disp_Table; function Actual_Subtype (Id : E) return E is @@ -1551,6 +1571,16 @@ package body Einfo is return Flag11 (Id); end Is_Inlined; + function Is_Interface (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private + or else Ekind (Id) = E_Class_Wide_Type); + return Flag186 (Id); + end Is_Interface; + function Is_Instantiated (Id : E) return B is begin return Flag126 (Id); @@ -2207,6 +2237,13 @@ package body Einfo is return Flag165 (Id); end Suppress_Style_Checks; + function Task_Body_Procedure (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Task_Type + or else Ekind (Id) = E_Task_Subtype); + return Node24 (Id); + end Task_Body_Procedure; + function Treat_As_Volatile (Id : E) return B is begin return Flag41 (Id); @@ -2434,15 +2471,31 @@ package body Einfo is -- Attribute Set Procedures -- ------------------------------ + procedure Set_Abstract_Interfaces (Id : E; V : L) is + begin + pragma Assert (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private); + Set_Elist24 (Id, V); + end Set_Abstract_Interfaces; + + procedure Set_Abstract_Interface_Alias (Id : E; V : E) is + begin + pragma Assert + (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function); + Set_Node25 (Id, V); + end Set_Abstract_Interface_Alias; + procedure Set_Accept_Address (Id : E; V : L) is begin Set_Elist21 (Id, V); end Set_Accept_Address; - procedure Set_Access_Disp_Table (Id : E; V : E) is + procedure Set_Access_Disp_Table (Id : E; V : L) is begin pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id)); - Set_Node16 (Id, V); + Set_Elist16 (Id, V); end Set_Access_Disp_Table; procedure Set_Associated_Final_Chain (Id : E; V : E) is @@ -3527,6 +3580,15 @@ package body Einfo is Set_Flag11 (Id, V); end Set_Is_Inlined; + procedure Set_Is_Interface (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Record_Type + or else Ekind (Id) = E_Record_Subtype + or else Ekind (Id) = E_Record_Type_With_Private + or else Ekind (Id) = E_Record_Subtype_With_Private); + Set_Flag186 (Id, V); + end Set_Is_Interface; + procedure Set_Is_Instantiated (Id : E; V : B := True) is begin Set_Flag126 (Id, V); @@ -4194,6 +4256,13 @@ package body Einfo is Set_Flag165 (Id, V); end Set_Suppress_Style_Checks; + procedure Set_Task_Body_Procedure (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Task_Type + or else Ekind (Id) = E_Task_Subtype); + Set_Node24 (Id, V); + end Set_Task_Body_Procedure; + procedure Set_Treat_As_Volatile (Id : E; V : B := True) is begin Set_Flag41 (Id, V); @@ -6039,11 +6108,11 @@ package body Einfo is return Kind; end Subtype_Kind; - ------------------- - -- Tag_Component -- - ------------------- + ------------------------- + -- First_Tag_Component -- + ------------------------- - function Tag_Component (Id : E) return E is + function First_Tag_Component (Id : E) return E is Comp : Entity_Id; Typ : Entity_Id := Id; @@ -6070,7 +6139,34 @@ package body Einfo is -- No tag component found return Empty; - end Tag_Component; + end First_Tag_Component; + + ------------------------ + -- Next_Tag_Component -- + ------------------------ + + function Next_Tag_Component (Id : E) return E is + Comp : Entity_Id; + Typ : constant Entity_Id := Scope (Id); + + begin + pragma Assert (Ekind (Id) = E_Component + and then Is_Tagged_Type (Typ)); + + Comp := Next_Entity (Id); + while Present (Comp) loop + if Is_Tag (Comp) then + pragma Assert (Chars (Comp) /= Name_uTag); + return Comp; + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- No tag component found + + return Empty; + end Next_Tag_Component; --------------------- -- Type_High_Bound -- @@ -6311,6 +6407,7 @@ package body Einfo is W ("Is_Imported", Flag24 (Id)); W ("Is_Inlined", Flag11 (Id)); W ("Is_Instantiated", Flag126 (Id)); + W ("Is_Interface", Flag186 (Id)); W ("Is_Internal", Flag17 (Id)); W ("Is_Interrupt_Handler", Flag89 (Id)); W ("Is_Intrinsic_Subprogram", Flag64 (Id)); @@ -6939,7 +7036,7 @@ package body Einfo is E_Procedure => Write_Str ("Alias"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Corresponding_Concurrent_Type"); when E_Entry_Index_Parameter => @@ -7255,9 +7352,18 @@ package body Einfo is procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Record_Type | + E_Record_Subtype | + E_Record_Type_With_Private | + E_Record_Subtype_With_Private => + Write_Str ("Abstract_Interfaces"); + when Subprogram_Kind => Write_Str ("Obsolescent_Warning"); + when Task_Kind => + Write_Str ("Task_Body_Procedure"); + when others => Write_Str ("Field24??"); end case; @@ -7270,6 +7376,10 @@ package body Einfo is procedure Write_Field25_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Procedure | + E_Function => + Write_Str ("Abstract_Interface_Alias"); + when others => Write_Str ("Field25??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 573539fa1ba..8218d9c66c5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index ad2dcbe1326..fd68f991430 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7c965cd2a7f..e832c5a5457 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 -- ---------------------------- diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 35084860c8c..06d8e7c0c00 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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;" diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1d027d05176..b3517bf18ba 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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) - - -- 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. + -- 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. 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,29 +5519,29 @@ package body Exp_Ch3 is begin Renamed_Eq := Empty; - -- Spec of _Alignment + -- Spec of _Size Append_To (Res, Predef_Spec_Or_Body (Loc, Tag_Typ => Tag_Typ, - Name => Name_uAlignment, + Name => Name_uSize, 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)); + Ret_Type => Standard_Long_Long_Integer)); - -- Spec of _Size + -- Spec of _Alignment Append_To (Res, Predef_Spec_Or_Body (Loc, Tag_Typ => Tag_Typ, - Name => Name_uSize, + 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_Long_Long_Integer)); + 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. diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 59f8ef71008..fcb7c9375ad 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fd03a08b411..525bf67c2c3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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); + return; + end if; - 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. + -- 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; + 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); + 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 + 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); + 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 + -- 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)))); + 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 if; + 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; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 819b576ca45..d78da78dbcb 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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. - - 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)) + -- 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)) 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; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index dbd692dd980..05c886a5be1 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 9cc9fb0098e..03001dc867e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 4c756b13317..e1c69b7a8f1 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -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 := diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 5968b72f4fc..928d52d0af1 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -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; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 7dcc6ba08e1..56ec4a15f39 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -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_Access => + return P_Access_Type_Definition; - when Tok_New => - return P_Formal_Derived_Type_Definition; + when Tok_Array => + return P_Array_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_Range => - return P_Formal_Signed_Integer_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_Digits => - return P_Formal_Floating_Point_Definition; - - when Tok_Delta => - return P_Formal_Fixed_Point_Definition; + when Tok_New => + return P_Formal_Derived_Type_Definition; - when Tok_Array => - return P_Array_Type_Definition; + when Tok_Private | + Tok_Tagged => + return P_Formal_Private_Type_Definition; - when Tok_Access => - return P_Access_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); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 5da4a3e10e1..d28f1a9a07d 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -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 - Type_Loc : Source_Ptr; - Type_Start_Col : Column_Number; - Ident_Node : Node_Id; + Abstract_Present : Boolean; + Abstract_Loc : Source_Ptr; Decl_Node : Node_Id; Discr_List : List_Id; - Unknown_Dis : Boolean; Discr_Sloc : Source_Ptr; - Abstract_Present : Boolean; - Abstract_Loc : Source_Ptr; End_Labl : Node_Id; + Type_Loc : Source_Ptr; + Type_Start_Col : Column_Number; + Ident_Node : Node_Id; + Is_Derived_Iface : Boolean := False; + Unknown_Dis : Boolean; - 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 -- ---------------------------------- diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 4c6da467634..eba22acbb28 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -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; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 6c8ec704e20..8b4e69081b7 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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. diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index bd3faa4c8c2..79dab061c25 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 408024b3715..b3019294715 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 33f330143e5..c6117ee7b7c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index bfbbdf838e2..c7df4dbd8d3 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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); diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 046826f617a..6dedcabeca4 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -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; |