From: Ed Schonberg Date: Fri, 6 Apr 2007 09:19:23 +0000 (+0200) Subject: errout.adb (Unwind_Internal_Type): Use predicate Is_Access__Protected_Subprogram_Type. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fea9e956ec1b3e1b95f79e44309cfa93314ddbce;p=gcc.git errout.adb (Unwind_Internal_Type): Use predicate Is_Access__Protected_Subprogram_Type. 2007-04-06 Ed Schonberg Robert Dewar Bob Duff Gary Dismukes * errout.adb (Unwind_Internal_Type): Use predicate Is_Access__Protected_Subprogram_Type. * freeze.adb (Size_Known): Use First/Next_Component_Or_Discriminant (Freeze_Entity, packed array case): Do not override explicitly set alignment and size clauses. (Freeze_Entity): An entity declared in an outer scope can be frozen if the enclosing subprogram is a child unit body that acts as a spec. (Freeze_Entity): Use new predicate Is_Access_Protected_Subprogram_Type. (Freeze_Record_Type): New Ada 2005 processing for reverse bit order Remove all code for DSP option * layout.adb (Layout_Record_Type): Use First/ Next_Component_Or_Discriminant (Layout_Type): Use new predicate Is_Access_Protected_Subprogram_Type, to handle properly the anonymous access case. * sem_attr.adb (Build_Access_Object_Type): Use E_Access_Attribute_Type for all access attributes, because overload resolution should work the same for 'Access, 'Unchecked_Access, and 'Unrestricted_Access. This causes the error message for the ambiguous "X'Access = Y'Access" and "X'Unrestricted_Access = Y'Access" and so forth to match. (Resolve_Attribute, case 'Access): Remove use of Original_Access_Type, now that anonymous access to protected operations have their own kind. (Resolve_Attribute): In case of dispatching call check the violation of restriction No_Dispatching_Calls. (Check_Array_Type): Check new -gnatyA array index style option * sem_ch3.ads, sem_ch3.adb (Derived_Type_Declaration): Reject an attempt to derive from a synchronized tagged type. (Analyze_Type_Declaration): If there is a incomplete tagged view of the type, inherit the class-wide type already created, because it may already have been used in a self-referential anonymous access component. (Mentions_T): Recognize self-referential anonymous access components that use (a subtype of) the class-wide type of the enclosing type. (Build_Derived_Record_Type): Add earlier setting of Is_Tagged_Type. Pass Derived_Type for Prev formal on call to Check_Anonymous_Access_Components rather than Empty. (Make_Incomplete_Type_Declaration): Add test for case where the type has a record extension in deciding whether to create a class-wide type, rather than just checking Tagged_Present. (Replace_Anonymous_Access_To_Protected_Subprogram): Procedure applies to stand-alone object declarations as well as component declarations. (Array_Type_Declaration): Initialize Packed_Array_Type to Empty, to prevent accidental overwriting when enclosing package appears in a limited_with_clause. (Array_Type_Declaration): If the component type is an anonymous access, the associated_node for the itype is the type declaration itself. (Add_Interface_Tag_Components): Modified to support concurrent types with abstract interfaces. (Check_Abstract_Interfaces): New subprogram that verifies the ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2). (Build_Derived_Record_Type): Add call to Analyze_Interface_Declaration to complete the decoration of synchronized interface types. Add also a call to Check_Abstract_Interfaces to verify the ARM rules. (Derive_Interface_Subprograms): Modified to support concurrent types with abstract interfaces. (Analyze_Subtype_Indication): Resolve the range with the given subtype mark, rather than delaying the full resolution depending on context. (Analyze_Component_Declaration,Analyze_Interface_Declaration, Analyze_Object_Declaration,Analyze_Subtype_Declaration, Array_Type_Declaration,Build_Derived_Record_Type, Build_Discriminated_Subtype,Check_Abstract_Overriding,Check_Completion, Derive_Interface_Subprograms,Derive_Subprogram,Make_Class_Wide_Type, Process_Full_View,Record_Type_Declaration): Split Is_Abstract flag into Is_Abstract_Subprogram and Is_Abstract_Type. Make sure these are called only when appropriate. (Copy_And_Swap): Copy Has_Unreferenced_Objects flag from full type to private type. (Analyze_Subtype_Declaration): For an access subtype declaration, create an itype reference for the anonymous designated subtype, to prevent scope anonmalies in gigi. (Build_Itype_Reference): New utility, to simplify construction of such references. From-SVN: r123559 --- diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c2dd5da6ebe..6e05ec93f34 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2706,7 +2706,7 @@ package body Errout is if Is_Access_Type (Ent) then if Ekind (Ent) = E_Access_Subprogram_Type or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type - or else Ekind (Ent) = E_Access_Protected_Subprogram_Type + or else Is_Access_Protected_Subprogram_Type (Ent) then Ent := Directly_Designated_Type (Ent); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5406f07cb61..f7876bafa86 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -727,144 +727,132 @@ package body Freeze is -- Loop through components - Comp := First_Entity (T); + Comp := First_Component_Or_Discriminant (T); while Present (Comp) loop - if Ekind (Comp) = E_Component - or else - Ekind (Comp) = E_Discriminant - then - Ctyp := Etype (Comp); + Ctyp := Etype (Comp); - -- We do not know the packed size if there is a - -- component clause present (we possibly could, - -- but this would only help in the case of a record - -- with partial rep clauses. That's because in the - -- case of full rep clauses, the size gets figured - -- out anyway by a different circuit). + -- We do not know the packed size if there is a component + -- clause present (we possibly could, but this would only + -- help in the case of a record with partial rep clauses. + -- That's because in the case of full rep clauses, the + -- size gets figured out anyway by a different circuit). - if Present (Component_Clause (Comp)) then - Packed_Size_Known := False; - end if; + if Present (Component_Clause (Comp)) then + Packed_Size_Known := False; + end if; - -- We need to identify a component that is an array - -- where the index type is an enumeration type with - -- non-standard representation, and some bound of the - -- type depends on a discriminant. - - -- This is because gigi computes the size by doing a - -- substituation of the appropriate discriminant value - -- in the size expression for the base type, and gigi - -- is not clever enough to evaluate the resulting - -- expression (which involves a call to rep_to_pos) - -- at compile time. - - -- It would be nice if gigi would either recognize that - -- this expression can be computed at compile time, or - -- alternatively figured out the size from the subtype - -- directly, where all the information is at hand ??? - - if Is_Array_Type (Etype (Comp)) - and then Present (Packed_Array_Type (Etype (Comp))) - then - declare - Ocomp : constant Entity_Id := - Original_Record_Component (Comp); - OCtyp : constant Entity_Id := Etype (Ocomp); - Ind : Node_Id; - Indtyp : Entity_Id; - Lo, Hi : Node_Id; + -- We need to identify a component that is an array where + -- the index type is an enumeration type with non-standard + -- representation, and some bound of the type depends on a + -- discriminant. - begin - Ind := First_Index (OCtyp); - while Present (Ind) loop - Indtyp := Etype (Ind); + -- This is because gigi computes the size by doing a + -- substituation of the appropriate discriminant value in + -- the size expression for the base type, and gigi is not + -- clever enough to evaluate the resulting expression (which + -- involves a call to rep_to_pos) at compile time. - if Is_Enumeration_Type (Indtyp) - and then Has_Non_Standard_Rep (Indtyp) - then - Lo := Type_Low_Bound (Indtyp); - Hi := Type_High_Bound (Indtyp); - - if Is_Entity_Name (Lo) - and then - Ekind (Entity (Lo)) = E_Discriminant - then - return False; - - elsif Is_Entity_Name (Hi) - and then - Ekind (Entity (Hi)) = E_Discriminant - then - return False; - end if; - end if; + -- It would be nice if gigi would either recognize that + -- this expression can be computed at compile time, or + -- alternatively figured out the size from the subtype + -- directly, where all the information is at hand ??? - Next_Index (Ind); - end loop; - end; - end if; + if Is_Array_Type (Etype (Comp)) + and then Present (Packed_Array_Type (Etype (Comp))) + then + declare + Ocomp : constant Entity_Id := + Original_Record_Component (Comp); + OCtyp : constant Entity_Id := Etype (Ocomp); + Ind : Node_Id; + Indtyp : Entity_Id; + Lo, Hi : Node_Id; - -- Clearly size of record is not known if the size of - -- one of the components is not known. + begin + Ind := First_Index (OCtyp); + while Present (Ind) loop + Indtyp := Etype (Ind); - if not Size_Known (Ctyp) then - return False; - end if; + if Is_Enumeration_Type (Indtyp) + and then Has_Non_Standard_Rep (Indtyp) + then + Lo := Type_Low_Bound (Indtyp); + Hi := Type_High_Bound (Indtyp); - -- Accumulate packed size if possible + if Is_Entity_Name (Lo) + and then Ekind (Entity (Lo)) = E_Discriminant + then + return False; - if Packed_Size_Known then + elsif Is_Entity_Name (Hi) + and then Ekind (Entity (Hi)) = E_Discriminant + then + return False; + end if; + end if; - -- We can only deal with elementary types, since for - -- non-elementary components, alignment enters into - -- the picture, and we don't know enough to handle - -- proper alignment in this context. Packed arrays - -- count as elementary if the representation is a - -- modular type. + Next_Index (Ind); + end loop; + end; + end if; - if Is_Elementary_Type (Ctyp) - or else (Is_Array_Type (Ctyp) - and then - Present (Packed_Array_Type (Ctyp)) - and then - Is_Modular_Integer_Type - (Packed_Array_Type (Ctyp))) - then - -- If RM_Size is known and static, then we can - -- keep accumulating the packed size. + -- Clearly size of record is not known if the size of + -- one of the components is not known. - if Known_Static_RM_Size (Ctyp) then + if not Size_Known (Ctyp) then + return False; + end if; - -- A little glitch, to be removed sometime ??? - -- gigi does not understand zero sizes yet. + -- Accumulate packed size if possible - if RM_Size (Ctyp) = Uint_0 then - Packed_Size_Known := False; + if Packed_Size_Known then - -- Normal case where we can keep accumulating - -- the packed array size. + -- We can only deal with elementary types, since for + -- non-elementary components, alignment enters into the + -- picture, and we don't know enough to handle proper + -- alignment in this context. Packed arrays count as + -- elementary if the representation is a modular type. - else - Packed_Size := Packed_Size + RM_Size (Ctyp); - end if; + if Is_Elementary_Type (Ctyp) + or else (Is_Array_Type (Ctyp) + and then Present (Packed_Array_Type (Ctyp)) + and then Is_Modular_Integer_Type + (Packed_Array_Type (Ctyp))) + then + -- If RM_Size is known and static, then we can + -- keep accumulating the packed size. - -- If we have a field whose RM_Size is not known - -- then we can't figure out the packed size here. + if Known_Static_RM_Size (Ctyp) then - else + -- A little glitch, to be removed sometime ??? + -- gigi does not understand zero sizes yet. + + if RM_Size (Ctyp) = Uint_0 then Packed_Size_Known := False; + + -- Normal case where we can keep accumulating the + -- packed array size. + + else + Packed_Size := Packed_Size + RM_Size (Ctyp); end if; - -- If we have a non-elementary type we can't figure - -- out the packed array size (alignment issues). + -- If we have a field whose RM_Size is not known then + -- we can't figure out the packed size here. else Packed_Size_Known := False; end if; + + -- If we have a non-elementary type we can't figure out + -- the packed array size (alignment issues). + + else + Packed_Size_Known := False; end if; end if; - Next_Entity (Comp); + Next_Component_Or_Discriminant (Comp); end loop; if Packed_Size_Known then @@ -1627,9 +1615,9 @@ package body Freeze is end if; -- If component clause is present, then deal with the - -- non-default bit order case. We cannot do this before - -- the freeze point, because there is no required order - -- for the component clause and the bit_order clause. + -- non-default bit order case for Ada 95 mode. The required + -- processing for Ada 2005 mode is handled separately after + -- processing all components. -- We only do this processing for the base type, and in -- fact that's important, since otherwise if there are @@ -1639,6 +1627,7 @@ package body Freeze is if Present (CC) and then Reverse_Bit_Order (Rec) and then Ekind (E) = E_Record_Type + and then Ada_Version <= Ada_95 then declare CFB : constant Uint := Component_Bit_Offset (Comp); @@ -1693,7 +1682,9 @@ package body Freeze is else -- Give warning if suspicious component clause - if Intval (FB) >= System_Storage_Unit then + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then Error_Msg_N ("?Bit_Order clause does not affect " & "byte ordering", Pos); @@ -1762,20 +1753,20 @@ package body Freeze is S : Entity_Id := Scope (Rec); begin - -- We have a pretty bad kludge here. Suppose Rec is a - -- subtype being defined in a subprogram that's created - -- as part of the freezing of Rec'Base. In that case, - -- we know that Comp'Base must have already been frozen by - -- the time we get to elaborate this because Gigi doesn't - -- elaborate any bodies until it has elaborated all of the - -- declarative part. But Is_Frozen will not be set at this - -- point because we are processing code in lexical order. - - -- We detect this case by going up the Scope chain of - -- Rec and seeing if we have a subprogram scope before - -- reaching the top of the scope chain or that of Comp'Base. - -- If we do, then mark that Comp'Base will actually be - -- frozen. If so, we merely undelay it. + -- We have a pretty bad kludge here. Suppose Rec is subtype + -- being defined in a subprogram that's created as part of + -- the freezing of Rec'Base. In that case, we know that + -- Comp'Base must have already been frozen by the time we + -- get to elaborate this because Gigi doesn't elaborate any + -- bodies until it has elaborated all of the declarative + -- part. But Is_Frozen will not be set at this point because + -- we are processing code in lexical order. + + -- We detect this case by going up the Scope chain of Rec + -- and seeing if we have a subprogram scope before reaching + -- the top of the scope chain or that of Comp'Base. If we + -- do, then mark that Comp'Base will actually be frozen. If + -- so, we merely undelay it. while Present (S) loop if Is_Subprogram (S) then @@ -1873,12 +1864,23 @@ package body Freeze is Next_Entity (Comp); end loop; - -- Check for useless pragma Bit_Order + -- Deal with pragma Bit_Order + + if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then + if not Placed_Component then + ADC := + Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); + Error_Msg_N + ("?Bit_Order specification has no effect", ADC); + Error_Msg_N + ("\?since no component clauses were specified", ADC); + + -- Here is where we do Ada 2005 processing for bit order (the + -- Ada 95 case was already taken care of above). - if not Placed_Component and then Reverse_Bit_Order (Rec) then - ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); - Error_Msg_N ("?Bit_Order specification has no effect", ADC); - Error_Msg_N ("\?since no component clauses were specified", ADC); + elsif Ada_Version >= Ada_05 then + Adjust_Record_For_Reverse_Bit_Order (Rec); + end if; end if; -- Check for useless pragma Pack when all components placed. We only @@ -2017,6 +2019,8 @@ package body Freeze is -- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram -- comes from source, or is a generic instance, then the freeze point -- is the one mandated by the language. and we freze the entity. + -- A subprogram that is a child unit body that acts as a spec does not + -- have a spec that comes from source, but can only come from source. elsif In_Open_Scopes (Scope (Test_E)) and then Scope (Test_E) /= Current_Scope @@ -2030,6 +2034,7 @@ package body Freeze is if Is_Overloadable (S) then if Comes_From_Source (S) or else Is_Generic_Instance (S) + or else Is_Child_Unit (S) then exit; else @@ -2320,17 +2325,6 @@ package body Freeze is Freeze_And_Append (Alias (E), Loc, Result); end if; - -- If the return type requires a transient scope, and we are on - -- a target allowing functions to return with a depressed stack - -- pointer, then we mark the function as requiring this treatment. - - if Ekind (E) = E_Function - and then Functions_Return_By_DSP_On_Target - and then Requires_Transient_Scope (Etype (E)) - then - Set_Function_Returns_With_DSP (E); - end if; - if not Is_Internal (E) then Freeze_Subprogram (E); end if; @@ -2766,10 +2760,17 @@ package body Freeze is Freeze_And_Append (Packed_Array_Type (E), Loc, Result); -- Size information of packed array type is copied to the - -- array type, since this is really the representation. + -- array type, since this is really the representation. But + -- do not override explicit existing size values. + + if not Has_Size_Clause (E) then + Set_Esize (E, Esize (Packed_Array_Type (E))); + Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); + end if; - Set_Size_Info (E, Packed_Array_Type (E)); - Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); + if not Has_Alignment_Clause (E) then + Set_Alignment (E, Alignment (Packed_Array_Type (E))); + end if; end if; -- For non-packed arrays set the alignment of the array @@ -2993,16 +2994,6 @@ package body Freeze is Next_Formal (Formal); end loop; - -- If the return type requires a transient scope, and we are on - -- a target allowing functions to return with a depressed stack - -- pointer, then we mark the function as requiring this treatment. - - if Functions_Return_By_DSP_On_Target - and then Requires_Transient_Scope (Etype (E)) - then - Set_Function_Returns_With_DSP (E); - end if; - Freeze_Subprogram (E); -- Ada 2005 (AI-326): Check wrong use of tag incomplete type @@ -3022,7 +3013,7 @@ package body Freeze is -- (however this is not set if we are not generating code or if this -- is an anonymous type used just for resolution). - elsif Ekind (E) = E_Access_Protected_Subprogram_Type then + elsif Is_Access_Protected_Subprogram_Type (E) then -- AI-326: Check wrong use of tagged incomplete types @@ -3192,10 +3183,6 @@ package body Freeze is if Is_Concurrent_Type (Aux_E) and then Present (Corresponding_Record_Type (Aux_E)) then - pragma Assert (not Is_Empty_Elmt_List - (Abstract_Interfaces - (Corresponding_Record_Type (Aux_E)))); - Prim_List := Primitive_Operations (Corresponding_Record_Type (Aux_E)); else @@ -4458,7 +4445,6 @@ package body Freeze is elsif Is_Record_Type (Typ) then C := First_Entity (Typ); - while Present (C) loop if Ekind (C) = E_Discriminant or else Ekind (C) = E_Component diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index b5b1ef97e53..22ef17d2e55 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -2252,12 +2252,9 @@ package body Layout is Prev_Comp := Empty; - Comp := First_Entity (E); + Comp := First_Component_Or_Discriminant (E); while Present (Comp) loop - if (Ekind (Comp) = E_Component - or else Ekind (Comp) = E_Discriminant) - and then Present (Component_Clause (Comp)) - then + if Present (Component_Clause (Comp)) then if No (Prev_Comp) or else Component_Bit_Offset (Comp) > @@ -2267,7 +2264,7 @@ package body Layout is end if; end if; - Next_Entity (Comp); + Next_Component_Or_Discriminant (Comp); end loop; -- We have two separate circuits, one for non-variant records and @@ -2336,7 +2333,7 @@ package body Layout is -- backend figure out what is needed (it may be some kind -- of fat pointer, including the static link for example. - elsif Ekind (E) = E_Access_Protected_Subprogram_Type then + elsif Is_Access_Protected_Subprogram_Type (E) then null; -- For access subtypes, copy the size information from base type diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 91a8b61601b..ffae61ba967 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -58,6 +58,8 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stringt; use Stringt; +with Style; +with Stylesw; use Stylesw; with Targparm; use Targparm; with Ttypes; use Ttypes; with Ttypef; use Ttypef; @@ -353,19 +355,10 @@ package body Sem_Attr is ------------------------------ function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is - Typ : Entity_Id; - + Typ : constant Entity_Id := + New_Internal_Entity + (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); begin - if Aname = Name_Unrestricted_Access then - Typ := - New_Internal_Entity - (E_Allocator_Type, Current_Scope, Loc, 'A'); - else - Typ := - New_Internal_Entity - (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); - end if; - Set_Etype (Typ, Typ); Init_Size_Align (Typ); Set_Is_Itype (Typ); @@ -841,6 +834,12 @@ package body Sem_Attr is Error_Attr ("invalid dimension number for array type", E1); end if; end if; + + if (Style_Check and Style_Check_Array_Attribute_Index) + and then Comes_From_Source (N) + then + Style.Check_Array_Attribute_Index (N, E1, D); + end if; end Check_Array_Type; ------------------------- @@ -1394,7 +1393,7 @@ package body Sem_Attr is -- Note: the double call to Root_Type here is needed because the -- root type of a class-wide type is the corresponding type (e.g. - -- X for X'Class, and we really want to go to the root. + -- X for X'Class, and we really want to go to the root.) if not Is_Access_Type (Etyp) or else Root_Type (Root_Type (Designated_Type (Etyp))) /= @@ -1900,7 +1899,28 @@ package body Sem_Attr is begin if Is_Subprogram (Ent) then - if not Is_Library_Level_Entity (Ent) then + if not Is_Library_Level_Entity (Ent) + + -- Do not take into account nodes generated by the + -- expander for the elaboration of the dispatch tables; + -- otherwise we erroneously generate warnings indicating + -- violation of restriction No_Implicit_Dynamic_Code + -- with those nodes. + + and then not (Is_Dispatching_Operation (Ent) + and then Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Indexed_Component + and then Nkind (Prefix (Name (Parent (N)))) = + N_Selected_Component + and then Nkind (Selector_Name + (Prefix (Name (Parent (N))))) = + N_Identifier + and then Present (Entity (Selector_Name + (Prefix (Name (Parent (N)))))) + and then Entity (Selector_Name + (Prefix (Name (Parent (N))))) = + RTE_Record_Component (RE_Prims_Ptr)) + then Check_Restriction (No_Implicit_Dynamic_Code, P); end if; @@ -7044,18 +7064,16 @@ package body Sem_Attr is if Is_Entity_Name (P) then if Is_Overloaded (P) then Get_First_Interp (P, Index, It); - while Present (It.Nam) loop - if Type_Conformant (Designated_Type (Typ), It.Nam) then Set_Entity (P, It.Nam); - -- The prefix is definitely NOT overloaded anymore - -- at this point, so we reset the Is_Overloaded - -- flag to avoid any confusion when reanalyzing - -- the node. + -- The prefix is definitely NOT overloaded anymore at + -- this point, so we reset the Is_Overloaded flag to + -- avoid any confusion when reanalyzing the node. Set_Is_Overloaded (P, False); + Set_Is_Overloaded (N, False); Generate_Reference (Entity (P), P); exit; end if; @@ -7063,12 +7081,20 @@ package body Sem_Attr is Get_Next_Interp (Index, It); end loop; - -- If it is a subprogram name or a type, there is nothing - -- to resolve. + -- If Prefix is a subprogram name, it is frozen by this + -- reference: + -- + -- If it is a type, there is nothing to resolve. + -- If it is an object, complete its resolution. - elsif not Is_Overloadable (Entity (P)) - and then not Is_Type (Entity (P)) - then + elsif Is_Overloadable (Entity (P)) then + if not In_Default_Expression then + Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); + end if; + + elsif Is_Type (Entity (P)) then + null; + else Resolve (P); end if; @@ -7077,8 +7103,8 @@ package body Sem_Attr is if not Is_Entity_Name (P) then null; - elsif Is_Abstract (Entity (P)) - and then Is_Overloadable (Entity (P)) + elsif Is_Overloadable (Entity (P)) + and then Is_Abstract_Subprogram (Entity (P)) then Error_Msg_N ("prefix of % attribute cannot be abstract", P); Set_Etype (N, Any_Type); @@ -7211,16 +7237,27 @@ package body Sem_Attr is if Enclosing_Generic_Unit (Entity (P)) /= Enclosing_Generic_Unit (Root_Type (Btyp)) then + Error_Msg_N + ("''Access attribute not allowed in generic body", + N); + if Root_Type (Btyp) = Btyp then - Error_Msg_N - ("access type must not be outside generic unit", - N); + Error_Msg_NE + ("\because " & + "access type & is declared outside " & + "generic unit ('R'M 3.10.2(32))", N, Btyp); else - Error_Msg_N - ("ancestor access type must not be outside " & - "generic unit", N); + Error_Msg_NE + ("\because ancestor of " & + "access type & is declared outside " & + "generic unit ('R'M 3.10.2(32))", N, Btyp); end if; + Error_Msg_NE + ("\move ''Access to private part, or " & + "(Ada 2005) use anonymous access type instead of &", + N, Btyp); + -- If the ultimate ancestor of the attribute's type is -- a formal type, then the attribute is illegal because -- the actual type might be declared at a higher level. @@ -7244,11 +7281,17 @@ package body Sem_Attr is end if; -- If this is a renaming, an inherited operation, or a - -- subprogram instance, use the original entity. + -- subprogram instance, use the original entity. This may make + -- the node type-inconsistent, so this transformation can only + -- be done if the node will not be reanalyzed. In particular, + -- if it is within a default expression, the transformation + -- must be delayed until the default subprogram is created for + -- it, when the enclosing subprogram is frozen. if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) and then Present (Alias (Entity (P))) + and then Expander_Active then Rewrite (P, New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); @@ -7520,7 +7563,6 @@ package body Sem_Attr is elsif Object_Access_Level (P) > Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type - and then No (Original_Access_Type (Typ)) then Accessibility_Message; return; @@ -7940,6 +7982,15 @@ package body Sem_Attr is when others => null; end case; + + -- If the prefix of the attribute is a class-wide type then it + -- will be expanded into a dispatching call to a predefined + -- primitive. Therefore we must check for potential violation + -- of such restriction. + + if Is_Class_Wide_Type (Etype (P)) then + Check_Restriction (No_Dispatching_Calls, N); + end if; end case; -- Normally the Freezing is done by Resolve but sometimes the Prefix @@ -7978,7 +8029,7 @@ package body Sem_Attr is end if; if Nam = TSS_Stream_Input - and then Is_Abstract (Typ) + and then Is_Abstract_Type (Typ) and then not Is_Class_Wide_Type (Typ) then return False; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 29efc4d9512..71afa7d1813 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -104,7 +104,7 @@ package body Sem_Ch3 is -- implicit derived full type for a type derived from a private type (in -- that case the subprograms must only be derived for the private view of -- the type). - + -- -- ??? These flags need a bit of re-examination and re-documentation: -- ??? are they both necessary (both seem related to the recursion)? @@ -227,6 +227,20 @@ package body Sem_Ch3 is -- Needs a more complete spec--what are the parameters exactly, and what -- exactly is the returned value, and how is Bound affected??? + procedure Build_Itype_Reference + (Ityp : Entity_Id; + Nod : Node_Id); + -- Create a reference to an internal type, for use by Gigi. The back-end + -- elaborates itypes on demand, i.e. when their first use is seen. This + -- can lead to scope anomalies if the first use is within a scope that is + -- nested within the scope that contains the point of definition of the + -- itype. The Itype_Reference node forces the elaboration of the itype + -- in the proper scope. The node is inserted after Nod, which is the + -- enclosing declaration that generated Ityp. + -- A related mechanism is used during expansion, for itypes created in + -- branches of conditionals. See Ensure_Defined in exp_util. + -- Could both mechanisms be merged ??? + procedure Build_Underlying_Full_View (N : Node_Id; Typ : Entity_Id; @@ -239,6 +253,9 @@ package body Sem_Ch3 is -- view cannot itself have a full view (it would get clobbered during -- view exchanges). + procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id); + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + procedure Check_Access_Discriminant_Requires_Limited (D : Node_Id; Loc : Node_Id); @@ -246,25 +263,39 @@ package body Sem_Ch3 is -- belongs must be a concurrent type or a descendant of a type with -- the reserved word 'limited' in its declaration. + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id); + -- Ada 2005 AI-382: an access component in a record definition can refer to + -- the enclosing record, in which case it denotes the type itself, and not + -- the current instance of the type. We create an anonymous access type for + -- the component, and flag it as an access to a component, so accessibility + -- checks are properly performed on it. The declaration of the access type + -- is placed ahead of that of the record to prevent order-of-elaboration + -- circularity issues in Gigi. We create an incomplete type for the record + -- declaration, which is the designated type of the anonymous access. + procedure Check_Delta_Expression (E : Node_Id); - -- Check that the expression represented by E is suitable for use - -- as a delta expression, i.e. it is of real type and is static. + -- Check that the expression represented by E is suitable for use as a + -- delta expression, i.e. it is of real type and is static. procedure Check_Digits_Expression (E : Node_Id); - -- Check that the expression represented by E is suitable for use as - -- a digits expression, i.e. it is of integer type, positive and static. + -- Check that the expression represented by E is suitable for use as a + -- digits expression, i.e. it is of integer type, positive and static. procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); - -- Validate the initialization of an object declaration. T is the - -- required type, and Exp is the initialization expression. + -- Validate the initialization of an object declaration. T is the required + -- type, and Exp is the initialization expression. procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id; Prev : Entity_Id := Empty); - -- If T is the full declaration of an incomplete or private type, check - -- the conformance of the discriminants, otherwise process them. Prev - -- is the entity of the partial declaration, if any. + -- If T is the full declaration of an incomplete or private type, check the + -- conformance of the discriminants, otherwise process them. Prev is the + -- entity of the partial declaration, if any. procedure Check_Real_Bound (Bound : Node_Id); -- Check given bound for being of real type and static. If not, post an @@ -283,19 +314,17 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id; Loc : Source_Ptr); - -- For derived scalar types, convert the bounds in the type definition - -- to the derived type, and complete their analysis. Given a constraint - -- of the form: - -- .. new T range Lo .. Hi; - -- Lo and Hi are analyzed and resolved with T'Base, the parent_type. - -- The bounds of the derived type (the anonymous base) are copies of - -- Lo and Hi. Finally, the bounds of the derived subtype are conversions - -- of those bounds to the derived_type, so that their typing is - -- consistent. + -- For derived scalar types, convert the bounds in the type definition to + -- the derived type, and complete their analysis. Given a constraint of the + -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with + -- T'Base, the parent_type. The bounds of the derived type (the anonymous + -- base) are copies of Lo and Hi. Finally, the bounds of the derived + -- subtype are conversions of those bounds to the derived_type, so that + -- their typing is consistent. procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); - -- Copies attributes from array base type T2 to array base type T1. - -- Copies only attributes that apply to base types, but not subtypes. + -- Copies attributes from array base type T2 to array base type T1. Copies + -- only attributes that apply to base types, but not subtypes. procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); -- Copies attributes from array subtype T2 to array subtype T1. Copies @@ -308,12 +337,12 @@ package body Sem_Ch3 is Constraints : Elist_Id); -- Build the list of entities for a constrained discriminated record -- subtype. If a component depends on a discriminant, replace its subtype - -- using the discriminant values in the discriminant constraint. - -- Subt is the defining identifier for the subtype whose list of - -- constrained entities we will create. Decl_Node is the type declaration - -- node where we will attach all the itypes created. Typ is the base - -- discriminated type for the subtype Subt. Constraints is the list of - -- discriminant constraints for Typ. + -- using the discriminant values in the discriminant constraint. Subt is + -- the defining identifier for the subtype whose list of constrained + -- entities we will create. Decl_Node is the type declaration node where we + -- will attach all the itypes created. Typ is the base discriminated type + -- for the subtype Subt. Constraints is the list of discriminant + -- constraints for Typ. function Constrain_Component_Type (Comp : Entity_Id; @@ -324,11 +353,12 @@ package body Sem_Ch3 is -- Given a discriminated base type Typ, a list of discriminant constraint -- Constraints for Typ and a component of Typ, with type Compon_Type, -- create and return the type corresponding to Compon_type where all - -- discriminant references are replaced with the corresponding - -- constraint. If no discriminant references occur in Compon_Typ then - -- return it as is. Constrained_Typ is the final constrained subtype to - -- which the constrained Compon_Type belongs. Related_Node is the node - -- where we will attach all the itypes created. + -- discriminant references are replaced with the corresponding constraint. + -- If no discriminant references occur in Compon_Typ then return it as is. + -- Constrained_Typ is the final constrained subtype to which the + -- constrained Compon_Type belongs. Related_Node is the node where we will + -- attach all the itypes created. + -- Above description is confused, what is Compon_Type??? procedure Constrain_Access (Def_Id : in out Entity_Id; @@ -418,10 +448,10 @@ package body Sem_Ch3 is Suffix : Character; Suffix_Index : Nat); -- Process an index constraint in a constrained array declaration. The - -- constraint can be a subtype name, or a range with or without an - -- explicit subtype mark. The index is the corresponding index of the - -- unconstrained array. The Related_Id and Suffix parameters are used to - -- build the associated Implicit type name. + -- constraint can be a subtype name, or a range with or without an explicit + -- subtype mark. The index is the corresponding index of the unconstrained + -- array. The Related_Id and Suffix parameters are used to build the + -- associated Implicit type name. procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); -- Build subtype of a signed or modular integer type @@ -431,9 +461,9 @@ package body Sem_Ch3 is -- build an E_Ordinary_Fixed_Point_Subtype entity. procedure Copy_And_Swap (Priv, Full : Entity_Id); - -- Copy the Priv entity into the entity of its full declaration - -- then swap the two entities in such a manner that the former private - -- type is now seen as a full type. + -- Copy the Priv entity into the entity of its full declaration then swap + -- the two entities in such a manner that the former private type is now + -- seen as a full type. procedure Decimal_Fixed_Point_Type_Declaration (T : Entity_Id; @@ -522,8 +552,8 @@ package body Sem_Ch3 is -- -- Is_Tagged is set if we are dealing with tagged types -- - -- If Inherit_Discr is set, Derived_Base inherits its discriminants - -- from Parent_Base, otherwise no discriminants are inherited. + -- If Inherit_Discr is set, Derived_Base inherits its discriminants from + -- Parent_Base, otherwise no discriminants are inherited. -- -- Discs gives the list of constraints that apply to Parent_Base in the -- derived type declaration. If Discs is set to No_Elist, then we have @@ -542,8 +572,8 @@ package body Sem_Ch3 is -- -- (Old_Component => New_Component), -- - -- where Old_Component is the Entity_Id of a component in Parent_Base - -- and New_Component is the Entity_Id of the corresponding component in + -- where Old_Component is the Entity_Id of a component in Parent_Base and + -- New_Component is the Entity_Id of the corresponding component in -- Derived_Base. For untagged records, this association list is needed when -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. @@ -684,6 +714,7 @@ package body Sem_Ch3 is and then Is_Task_Type (Etype (Scope (Current_Scope))) then Error_Msg_N ("task entries cannot have access parameters", N); + return Empty; end if; -- Ada 2005: for an object declaration the corresponding anonymous @@ -701,24 +732,26 @@ package body Sem_Ch3 is (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Current_Scope); - -- For the anonymous function result case, retrieve the scope of - -- the function specification's associated entity rather than using - -- the current scope. The current scope will be the function itself - -- if the formal part is currently being analyzed, but will be the - -- parent scope in the case of a parameterless function, and we - -- always want to use the function's parent scope. + -- For the anonymous function result case, retrieve the scope of the + -- function specification's associated entity rather than using the + -- current scope. The current scope will be the function itself if the + -- formal part is currently being analyzed, but will be the parent scope + -- in the case of a parameterless function, and we always want to use + -- the function's parent scope. Finally, if the function is a child + -- unit, we must traverse the the tree to retrieve the proper entity. elsif Nkind (Related_Nod) = N_Function_Specification and then Nkind (Parent (N)) /= N_Parameter_Specification then Anon_Type := Create_Itype - (E_Anonymous_Access_Type, Related_Nod, - Scope_Id => Scope (Defining_Unit_Name (Related_Nod))); + (E_Anonymous_Access_Type, + Related_Nod, + Scope_Id => Scope (Defining_Entity (Related_Nod))); else - -- For access formals, access components, and access - -- discriminants, the scope is that of the enclosing declaration, + -- For access formals, access components, and access discriminants, + -- the scope is that of the enclosing declaration, Anon_Type := Create_Itype @@ -732,8 +765,8 @@ package body Sem_Ch3 is Error_Msg_N ("ALL is not permitted for anonymous access types", N); end if; - -- Ada 2005 (AI-254): In case of anonymous access to subprograms - -- call the corresponding semantic routine + -- Ada 2005 (AI-254): In case of anonymous access to subprograms call + -- the corresponding semantic routine if Present (Access_To_Subprogram_Definition (N)) then Access_Subprogram_Declaration @@ -761,9 +794,8 @@ package body Sem_Ch3 is Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type)); -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs - -- from Ada 95 semantics. In Ada 2005, anonymous access must specify - -- if the null value is allowed. In Ada 95 the null value is never - -- allowed. + -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if + -- the null value is allowed. In Ada 95 the null value is never allowed. if Ada_Version >= Ada_05 then Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); @@ -804,9 +836,9 @@ package body Sem_Ch3 is -- Ada 2005: if the designated type is an interface that may contain -- tasks, create a Master entity for the declaration. This must be done - -- before expansion of the full declaration, because the declaration - -- may include an expression that is an allocator, whose expansion needs - -- the proper Master for the created tasks. + -- before expansion of the full declaration, because the declaration may + -- include an expression that is an allocator, whose expansion needs the + -- proper Master for the created tasks. if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active @@ -845,6 +877,16 @@ package body Sem_Ch3 is end if; end if; + -- For a private component of a protected type, it is imperative that + -- the back-end elaborate the type immediately after the protected + -- declaration, because this type will be used in the declarations + -- created for the component within each protected body, so we must + -- create an itype reference for it now. + + if Nkind (Parent (Related_Nod)) = N_Protected_Definition then + Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); + end if; + return Anon_Type; end Access_Definition; @@ -864,8 +906,8 @@ package body Sem_Ch3 is Create_Itype (E_Subprogram_Type, Parent (T_Def)); begin - -- Associate the Itype node with the inner full-type declaration - -- or subprogram spec. This is required to handle nested anonymous + -- Associate the Itype node with the inner full-type declaration or + -- subprogram spec. This is required to handle nested anonymous -- declarations. For example: -- procedure P @@ -1109,9 +1151,30 @@ package body Sem_Ch3 is Last_Tag : Node_Id; Comp : Node_Id; + procedure Add_Sync_Iface_Tags (T : Entity_Id); + -- Local subprogram used to recursively climb through the parents + -- of T to add the tags of all the progenitor interfaces. + procedure Add_Tag (Iface : Entity_Id); -- Add tag for one of the progenitor interfaces + ------------------------- + -- Add_Sync_Iface_Tags -- + ------------------------- + + procedure Add_Sync_Iface_Tags (T : Entity_Id) is + begin + if Etype (T) /= T then + Add_Sync_Iface_Tags (Etype (T)); + end if; + + Elmt := First_Elmt (Abstract_Interfaces (T)); + while Present (Elmt) loop + Add_Tag (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end Add_Sync_Iface_Tags; + ------------- -- Add_Tag -- ------------- @@ -1191,69 +1254,80 @@ package body Sem_Ch3 is end if; end Add_Tag; + -- Local variables + + Iface_List : List_Id; + -- Start of processing for Add_Interface_Tag_Components begin if Ekind (Typ) /= E_Record_Type - or else No (Abstract_Interfaces (Typ)) - or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) or else not RTE_Available (RE_Interface_Tag) + or else (Is_Concurrent_Record_Type (Typ) + and then Is_Empty_List (Abstract_Interface_List (Typ))) + or else (not Is_Concurrent_Record_Type (Typ) + and then No (Abstract_Interfaces (Typ)) + and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) then return; end if; - if Present (Abstract_Interfaces (Typ)) then + -- Find the current last tag + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + Ext := Record_Extension_Part (Type_Definition (N)); + else + pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); + Ext := Type_Definition (N); + end if; - -- Find the current last tag + Last_Tag := Empty; + if not (Present (Component_List (Ext))) then + Set_Null_Present (Ext, False); + L := New_List; + Set_Component_List (Ext, + Make_Component_List (Loc, + Component_Items => L, + Null_Present => False)); + else if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then - Ext := Record_Extension_Part (Type_Definition (N)); + L := Component_Items + (Component_List + (Record_Extension_Part + (Type_Definition (N)))); else - pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); - Ext := Type_Definition (N); + L := Component_Items + (Component_List + (Type_Definition (N))); end if; - Last_Tag := Empty; + -- Find the last tag component - if not (Present (Component_List (Ext))) then - Set_Null_Present (Ext, False); - L := New_List; - Set_Component_List (Ext, - Make_Component_List (Loc, - Component_Items => L, - Null_Present => False)); - else - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then - L := Component_Items - (Component_List - (Record_Extension_Part - (Type_Definition (N)))); - else - L := Component_Items - (Component_List - (Type_Definition (N))); + Comp := First (L); + while Present (Comp) loop + if Is_Tag (Defining_Identifier (Comp)) then + Last_Tag := Comp; end if; - -- Find the last tag component - - Comp := First (L); - while Present (Comp) loop - if Is_Tag (Defining_Identifier (Comp)) then - Last_Tag := Comp; - end if; + Next (Comp); + end loop; + end if; - Next (Comp); - end loop; - end if; + -- At this point L references the list of components and Last_Tag + -- references the current last tag (if any). Now we add the tag + -- corresponding with all the interfaces that are not implemented + -- by the parent. - -- At this point L references the list of components and Last_Tag - -- references the current last tag (if any). Now we add the tag - -- corresponding with all the interfaces that are not implemented - -- by the parent. + if Is_Concurrent_Record_Type (Typ) then + Iface_List := Abstract_Interface_List (Typ); - pragma Assert (Present - (First_Elmt (Abstract_Interfaces (Typ)))); + if Is_Non_Empty_List (Iface_List) then + Add_Sync_Iface_Tags (Etype (First (Iface_List))); + end if; + end if; + if Present (Abstract_Interfaces (Typ)) then Elmt := First_Elmt (Abstract_Interfaces (Typ)); while Present (Elmt) loop Add_Tag (Node (Elmt)); @@ -1396,7 +1470,7 @@ package body Sem_Ch3 is (Access_Definition (Component_Definition (N)))) then - T := Replace_Anonymous_Access_To_Protected_Subprogram (N, T); + T := Replace_Anonymous_Access_To_Protected_Subprogram (N); end if; end if; @@ -1485,7 +1559,7 @@ package body Sem_Ch3 is -- Components cannot be abstract, except for the special case of -- the _Parent field (case of extending an abstract tagged type) - elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then + elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then Error_Msg_N ("type of a component cannot be abstract", N); end if; @@ -1674,11 +1748,19 @@ package body Sem_Ch3 is end if; -- If next node is a body then freeze all types before the body. - -- An exception occurs for expander generated bodies, which can - -- be recognized by their already being analyzed. The expander - -- ensures that all types needed by these bodies have been frozen - -- but it is not necessary to freeze all types (and would be wrong - -- since it would not correspond to an RM defined freeze point). + -- An exception occurs for some expander-generated bodies. If these + -- are generated at places where in general language rules would not + -- allow a freeze point, then we assume that the expander has + -- explicitly checked that all required types are properly frozen, + -- and we do not cause general freezing here. This special circuit + -- is used when the encountered body is marked as having already + -- been analyzed. + + -- In all other cases (bodies that come from source, and expander + -- generated bodies that have not been analyzed yet), freeze all + -- types now. Note that in the latter case, the expander must take + -- care to attach the bodies at a proper place in the tree so as to + -- not cause unwanted freezing at that point. elsif not Analyzed (Next_Node) and then (Nkind (Next_Node) = N_Subprogram_Body @@ -1765,8 +1847,8 @@ package body Sem_Ch3 is -- Type is abstract if full declaration carries keyword, or if -- previous partial view did. - Set_Is_Abstract (T); - Set_Is_Interface (T); + Set_Is_Abstract_Type (T); + Set_Is_Interface (T); Set_Is_Limited_Interface (T, Limited_Present (Def)); Set_Is_Protected_Interface (T, Protected_Present (Def)); @@ -2061,6 +2143,15 @@ package body Sem_Ch3 is T := Find_Type_Of_Object (Object_Definition (N), N); + if Nkind (Object_Definition (N)) = N_Access_Definition + and then Present + (Access_To_Subprogram_Definition (Object_Definition (N))) + and then Protected_Present + (Access_To_Subprogram_Definition (Object_Definition (N))) + then + T := Replace_Anonymous_Access_To_Protected_Subprogram (N); + end if; + if Error_Posted (Id) then Set_Etype (Id, T); Set_Ekind (Id, E_Variable); @@ -2241,7 +2332,7 @@ package body Sem_Ch3 is -- x'class'input where x is abstract) where we legitimately -- generate an abstract object. - if Is_Abstract (T) and then Comes_From_Source (N) then + if Is_Abstract_Type (T) and then Comes_From_Source (N) then Error_Msg_N ("type of object cannot be abstract", Object_Definition (N)); @@ -3035,7 +3126,7 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); - Set_Is_Abstract (Id, Is_Abstract (T)); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); Set_Primitive_Operations (Id, Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); @@ -3053,11 +3144,10 @@ package body Sem_Ch3 is (Id, Has_Unknown_Discriminants (T)); if Is_Tagged_Type (T) then - Set_Is_Tagged_Type (Id); - Set_Is_Abstract (Id, Is_Abstract (T)); - Set_Primitive_Operations - (Id, Primitive_Operations (T)); - Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Is_Tagged_Type (Id); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); + Set_Primitive_Operations (Id, Primitive_Operations (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); end if; -- In general the attributes of the subtype of a private type @@ -3275,6 +3365,7 @@ package body Sem_Ch3 is if R /= Error then Analyze (R); Set_Etype (N, Etype (R)); + Resolve (R, Entity (T)); else Set_Error_Posted (R); Set_Error_Posted (T); @@ -3293,10 +3384,9 @@ package body Sem_Ch3 is Is_Remote : constant Boolean := (Is_Remote_Types (Current_Scope) - or else Is_Remote_Call_Interface (Current_Scope)) - and then not (In_Private_Part (Current_Scope) - or else - In_Package_Body (Current_Scope)); + or else Is_Remote_Call_Interface (Current_Scope)) + and then not (In_Private_Part (Current_Scope) + or else In_Package_Body (Current_Scope)); procedure Check_Ops_From_Incomplete_Type; -- If there is a tagged incomplete partial view of the type, transfer @@ -3351,11 +3441,24 @@ package body Sem_Ch3 is -- Ada 2005 (AI-50217): If the type was previously decorated when -- imported through a LIMITED WITH clause, it appears as incomplete -- but has no full view. + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the full view as well, to prevent + -- multiple incompatible class-wide types that may be created for + -- self-referential anonymous access components. if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) then T := Full_View (Prev); + + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (T, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (T, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (T), T); + end if; + else T := Prev; end if; @@ -3517,7 +3620,18 @@ package body Sem_Ch3 is -- made which is the "real" entity, i.e. the one swapped in, -- and the second parameter provides the reference location. - Generate_Reference (T, T, 'c'); + -- Also, we want to kill Has_Pragma_Unreferenced temporarily here + -- since we don't want a complaint about the full type being an + -- unwanted reference to the private type + + declare + B : constant Boolean := Has_Pragma_Unreferenced (T); + begin + Set_Has_Pragma_Unreferenced (T, False); + Generate_Reference (T, T, 'c'); + Set_Has_Pragma_Unreferenced (T, B); + end; + Set_Completion_Referenced (Def_Id); -- For completion of incomplete type, process incomplete dependents @@ -3727,11 +3841,21 @@ package body Sem_Ch3 is -- Ada 2005 (AI-230): Access Definition case else pragma Assert (Present (Access_Definition (Component_Def))); + + -- Indicate that the anonymous access type is created by the + -- array type declaration. + Element_Type := Access_Definition - (Related_Nod => Related_Id, + (Related_Nod => P, N => Access_Definition (Component_Def)); Set_Is_Local_Anonymous_Access (Element_Type); + -- Propagate the parent. This field is needed if we have to generate + -- the master_id associated with an anonymous access to task type + -- component (see Expand_N_Full_Type_Declaration.Build_Master) + + Set_Parent (Element_Type, Parent (T)); + -- Ada 2005 (AI-230): In case of components that are anonymous -- access types the level of accessibility depends on the enclosing -- type declaration @@ -3747,8 +3871,7 @@ package body Sem_Ch3 is begin if Present (CD) and then Protected_Present (CD) then Element_Type := - Replace_Anonymous_Access_To_Protected_Subprogram - (Def, Element_Type); + Replace_Anonymous_Access_To_Protected_Subprogram (Def); end if; end; end if; @@ -3782,18 +3905,19 @@ package body Sem_Ch3 is -- Complete setup of implicit base type - Set_First_Index (Implicit_Base, First_Index (T)); - Set_Component_Type (Implicit_Base, Element_Type); - Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); - Set_Component_Size (Implicit_Base, Uint_0); + Set_First_Index (Implicit_Base, First_Index (T)); + Set_Component_Type (Implicit_Base, Element_Type); + Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); + Set_Component_Size (Implicit_Base, Uint_0); + Set_Packed_Array_Type (Implicit_Base, Empty); Set_Has_Controlled_Component - (Implicit_Base, Has_Controlled_Component - (Element_Type) - or else - Is_Controlled (Element_Type)); + (Implicit_Base, Has_Controlled_Component + (Element_Type) + or else Is_Controlled + (Element_Type)); Set_Finalize_Storage_Only - (Implicit_Base, Finalize_Storage_Only - (Element_Type)); + (Implicit_Base, Finalize_Storage_Only + (Element_Type)); -- Unconstrained array case @@ -3815,7 +3939,10 @@ package body Sem_Ch3 is (Element_Type)); end if; + -- Common attributes for both cases + Set_Component_Type (Base_Type (T), Element_Type); + Set_Packed_Array_Type (T, Empty); if Aliased_Present (Component_Definition (Def)) then Set_Has_Aliased_Components (Etype (T)); @@ -3885,7 +4012,7 @@ package body Sem_Ch3 is ("unconstrained element type in array declaration", Subtype_Indication (Component_Def)); - elsif Is_Abstract (Element_Type) then + elsif Is_Abstract_Type (Element_Type) then Error_Msg_N ("the type of a component cannot be abstract", Subtype_Indication (Component_Def)); @@ -3898,8 +4025,7 @@ package body Sem_Ch3 is ------------------------------------------------------ function Replace_Anonymous_Access_To_Protected_Subprogram - (N : Node_Id; - Prev_E : Entity_Id) return Entity_Id + (N : Node_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (N); @@ -3923,15 +4049,19 @@ package body Sem_Ch3 is N_Unconstrained_Array_Definition | N_Constrained_Array_Definition => Comp := Component_Definition (N); - Acc := Access_Definition (Component_Definition (N)); + Acc := Access_Definition (Comp); when N_Discriminant_Specification => Comp := Discriminant_Type (N); - Acc := Discriminant_Type (N); + Acc := Comp; when N_Parameter_Specification => Comp := Parameter_Type (N); - Acc := Parameter_Type (N); + Acc := Comp; + + when N_Object_Declaration => + Comp := Object_Definition (N); + Acc := Comp; when others => raise Program_Error; @@ -3969,6 +4099,11 @@ package body Sem_Ch3 is Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); Set_Etype (Defining_Identifier (N), Anon); Set_Null_Exclusion_Present (N, False); + + elsif Nkind (N) = N_Object_Declaration then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + Set_Etype (Defining_Identifier (N), Anon); + else Rewrite (Comp, Make_Component_Definition (Loc, @@ -3980,11 +4115,15 @@ package body Sem_Ch3 is -- Temporarily remove the current scope from the stack to add the new -- declarations to the enclosing scope - Scope_Stack.Decrement_Last; - Analyze (Decl); - Scope_Stack.Append (Curr_Scope); + if Nkind (N) /= N_Object_Declaration then + Scope_Stack.Decrement_Last; + Analyze (Decl); + Scope_Stack.Append (Curr_Scope); + else + Analyze (Decl); + end if; - Set_Original_Access_Type (Anon, Prev_E); + Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); return Anon; end Replace_Anonymous_Access_To_Protected_Subprogram; @@ -5134,32 +5273,25 @@ package body Sem_Ch3 is -- be possibly non-private. We build a underlying full view that -- will be installed when the enclosing child body is compiled. - declare - IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); + Full_Der := + Make_Defining_Identifier (Sloc (Derived_Type), + Chars => Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Build_Itype_Reference (Full_Der, N); - begin - Full_Der := - Make_Defining_Identifier (Sloc (Derived_Type), - Chars (Derived_Type)); - Set_Is_Itype (Full_Der); - Set_Itype (IR, Full_Der); - Insert_After (N, IR); - - -- The full view will be used to swap entities on entry/exit - -- to the body, and must appear in the entity list for the - -- package. - - Append_Entity (Full_Der, Scope (Derived_Type)); - Set_Has_Private_Declaration (Full_Der); - Set_Has_Private_Declaration (Derived_Type); - Set_Associated_Node_For_Itype (Full_Der, N); - Set_Parent (Full_Der, Parent (Derived_Type)); - Full_P := Full_View (Parent_Type); - Exchange_Declarations (Parent_Type); - Copy_And_Build; - Exchange_Declarations (Full_P); - Set_Underlying_Full_View (Derived_Type, Full_Der); - end; + -- The full view will be used to swap entities on entry/exit to + -- the body, and must appear in the entity list for the package. + + Append_Entity (Full_Der, Scope (Derived_Type)); + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, Parent (Derived_Type)); + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); + Set_Underlying_Full_View (Derived_Type, Full_Der); end if; end if; end Build_Derived_Private_Type; @@ -5179,12 +5311,12 @@ package body Sem_Ch3 is -- type R (...) is [tagged] record ... end record; -- type T (...) is new R (...) [with ...]; - -- The representation clauses of T can specify a completely different - -- record layout from R's. Hence the same component can be placed in - -- two very different positions in objects of type T and R. If R and T - -- are tagged types, representation clauses for T can only specify the - -- layout of non inherited components, thus components that are common - -- in R and T have the same position in objects of type R and T. + -- The representation clauses for T can specify a completely different + -- record layout from R's. Hence the same component can be placed in two + -- very different positions in objects of type T and R. If R and are tagged + -- types, representation clauses for T can only specify the layout of non + -- inherited components, thus components that are common in R and T have + -- the same position in objects of type R and T. -- This has two implications. The first is that the entire tree for R's -- declaration needs to be copied for T in the untagged case, so that T @@ -5651,23 +5783,28 @@ package body Sem_Ch3 is end if; -- Before we start the previously documented transformations, here is - -- a little fix for size and alignment of tagged types. Normally when - -- we derive type D from type P, we copy the size and alignment of P - -- as the default for D, and in the absence of explicit representation - -- clauses for D, the size and alignment are indeed the same as the - -- parent. + -- little fix for size and alignment of tagged types. Normally when we + -- derive type D from type P, we copy the size and alignment of P as the + -- default for D, and in the absence of explicit representation clauses + -- for D, the size and alignment are indeed the same as the parent. + + -- But this is wrong for tagged types, since fields may be added, and + -- the default size may need to be larger, and the default alignment may + -- need to be larger. - -- But this is wrong for tagged types, since fields may be added, - -- and the default size may need to be larger, and the default - -- alignment may need to be larger. + -- We therefore reset the size and alignment fields in the tagged case. + -- Note that the size and alignment will in any case be at least as + -- large as the parent type (since the derived type has a copy of the + -- parent type in the _parent field) - -- We therefore reset the size and alignment fields in the tagged - -- case. Note that the size and alignment will in any case be at - -- least as large as the parent type (since the derived type has - -- a copy of the parent type in the _parent field) + -- The type is also marked as being tagged here, which is needed when + -- processing components with a self-referential anonymous access type + -- in the call to Check_Anonymous_Access_Components below. Note that + -- this flag is also set later on for completeness. if Is_Tagged then - Init_Size_Align (Derived_Type); + Set_Is_Tagged_Type (Derived_Type); + Init_Size_Align (Derived_Type); end if; -- STEP 0a: figure out what kind of derived type declaration we have @@ -5688,6 +5825,16 @@ package body Sem_Ch3 is if Present (Record_Extension_Part (Type_Def)) then Set_Ekind (Derived_Type, E_Record_Type); + + -- Create internal access types for components with anonymous + -- access types. + + if Ada_Version >= Ada_05 then + Check_Anonymous_Access_Components + (N, Derived_Type, Derived_Type, + Component_List (Record_Extension_Part (Type_Def))); + end if; + else Set_Ekind (Derived_Type, Ekind (Parent_Base)); end if; @@ -5966,7 +6113,6 @@ package body Sem_Ch3 is if Ada_Version = Ada_05 and then Is_Tagged then - -- "The declaration of a specific descendant of an interface type -- freezes the interface type" (RM 13.14). @@ -6198,7 +6344,10 @@ package body Sem_Ch3 is and then Ekind (Derived_Type) /= E_Private_Type and then Ekind (Derived_Type) /= E_Limited_Private_Type then - Set_Is_Interface (Derived_Type, Interface_Present (Type_Def)); + if Interface_Present (Type_Def) then + Analyze_Interface_Declaration (Derived_Type, Type_Def); + end if; + Set_Abstract_Interfaces (Derived_Type, No_Elist); end if; @@ -6210,13 +6359,16 @@ package body Sem_Ch3 is (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite (Derived_Type, Is_Limited_Composite (Parent_Type)); - Set_Is_Limited_Record - (Derived_Type, - Is_Limited_Record (Parent_Type) - and then not Is_Interface (Parent_Type)); Set_Is_Private_Composite (Derived_Type, Is_Private_Composite (Parent_Type)); + if not Is_Limited_Record (Derived_Type) then + Set_Is_Limited_Record + (Derived_Type, + Is_Limited_Record (Parent_Type) + and then not Is_Interface (Parent_Type)); + end if; + -- Fields inherited from the Parent_Base Set_Has_Controlled_Component @@ -6278,7 +6430,7 @@ package body Sem_Ch3 is end if; Make_Class_Wide_Type (Derived_Type); - Set_Is_Abstract (Derived_Type, Abstract_Present (Type_Def)); + Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); if Has_Discriminants (Derived_Type) and then Constraint_Present @@ -6287,13 +6439,17 @@ package body Sem_Ch3 is (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); end if; - -- Ada 2005 (AI-251): Collect the list of progenitors that are not - -- already in the parents. - if Ada_Version >= Ada_05 then declare Ifaces_List : Elist_Id; begin + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + + Check_Abstract_Interfaces (N, Type_Def); + + -- Ada 2005 (AI-251): Collect the list of progenitors that are + -- not already in the parents. + Collect_Abstract_Interfaces (T => Derived_Type, Ifaces_List => Ifaces_List, @@ -6395,7 +6551,9 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces if we are in expansion mode - if Expander_Active then + if Expander_Active + and then Has_Abstract_Interfaces (Derived_Type) + then Add_Interface_Tag_Components (N, Derived_Type); end if; @@ -7025,7 +7183,7 @@ package body Sem_Ch3 is Set_Primitive_Operations (Def_Id, Primitive_Operations (T)); end if; - Set_Is_Abstract (Def_Id, Is_Abstract (T)); + Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); end if; -- Subtypes introduced by component declarations do not need to be @@ -7059,6 +7217,20 @@ package body Sem_Ch3 is end if; end Build_Discriminated_Subtype; + --------------------------- + -- Build_Itype_Reference -- + --------------------------- + + procedure Build_Itype_Reference + (Ityp : Entity_Id; + Nod : Node_Id) + is + IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); + begin + Set_Itype (IR, Ityp); + Insert_After (Nod, IR); + end Build_Itype_Reference; + ------------------------ -- Build_Scalar_Bound -- ------------------------ @@ -7206,6 +7378,131 @@ package body Sem_Ch3 is Set_Underlying_Full_View (Typ, Full_View (Subt)); end Build_Underlying_Full_View; + ------------------------------- + -- Check_Abstract_Interfaces -- + ------------------------------- + + procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Local subprogram used to avoid code duplication. In case of error + -- the message will be associated to Error_Node. + + ------------------ + -- Check_Ifaces -- + ------------------ + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + begin + -- Ada 2005 (AI-345): Protected interfaces can only inherit from + -- limited, synchronized or protected interfaces. + + if Protected_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. + + elsif Synchronized_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from protected interface", Error_Node); + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. + + elsif Task_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " non-limited interface", Error_Node); + end if; + end if; + end Check_Ifaces; + + -- Local variables + + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + + -- Start of processing for Check_Abstract_Interfaces + + begin + -- Why is this still unsupported??? + + if Nkind (N) = N_Private_Extension_Declaration then + return; + end if; + + -- Check the parent in case of derivation of interface type + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Etype (Defining_Identifier (N))) + then + Check_Ifaces + (Iface_Def => Type_Definition + (Parent (Etype (Defining_Identifier (N)))), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); + end if; + + Next (Iface); + end loop; + end Check_Abstract_Interfaces; + ------------------------------- -- Check_Abstract_Overriding -- ------------------------------- @@ -7231,19 +7528,23 @@ package body Sem_Ch3 is -- come from source, and the associated source location is the -- location of the first subtype of the derived type. + -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for + -- subprograms that "require overriding". + -- Special exception, do not complain about failure to override the -- stream routines _Input and _Output, as well as the primitive -- operations used in dispatching selects since we always provide -- automatic overridings for these subprograms. - if (Is_Abstract (Subp) - or else (Has_Controlling_Result (Subp) - and then Present (Alias_Subp) - and then not Comes_From_Source (Subp) - and then Sloc (Subp) = Sloc (First_Subtype (T)))) + if (Is_Abstract_Subprogram (Subp) + or else Requires_Overriding (Subp) + or else (Has_Controlling_Result (Subp) + and then Present (Alias_Subp) + and then not Comes_From_Source (Subp) + and then Sloc (Subp) = Sloc (First_Subtype (T)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) - and then not Is_Abstract (T) + and then not Is_Abstract_Type (T) and then Chars (Subp) /= Name_uDisp_Asynchronous_Select and then Chars (Subp) /= Name_uDisp_Conditional_Select and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind @@ -7280,7 +7581,8 @@ package body Sem_Ch3 is or else not Is_Null_Extension (T) or else Ekind (Subp) = E_Procedure or else not Has_Controlling_Result (Subp) - or else Is_Abstract (Alias_Subp) + or else Is_Abstract_Subprogram (Alias_Subp) + or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then Error_Msg_NE @@ -7347,12 +7649,17 @@ package body Sem_Ch3 is end if; else - Error_Msg_NE - ("abstract subprogram not allowed for type&", - Subp, T); - Error_Msg_NE - ("nonabstract type has abstract subprogram&", - T, Subp); + Error_Msg_Node_2 := T; + Error_Msg_N + ("abstract subprogram& not allowed for type&", Subp); + + -- Also post unconditional warning on the type (unconditional + -- so that if there are more than one of these cases, we get + -- them all, and not just the first one). + + Error_Msg_Node_2 := Subp; + Error_Msg_N + ("nonabstract type& has abstract subprogram&!", T); end if; end if; @@ -7479,7 +7786,7 @@ package body Sem_Ch3 is -- If a generated entity has no completion, then either previous -- semantic errors have disabled the expansion phase, or else we had - -- missing subunits, or else we are compiling without expan- sion, + -- missing subunits, or else we are compiling without expansion, -- or else something is very wrong. if not Comes_From_Source (E) then @@ -7571,13 +7878,23 @@ package body Sem_Ch3 is -- be flagged as requiring completion, because it is a -- compilation unit. + -- Ignore missing completion for a subprogram that does not come from + -- source (including the _Call primitive operation of RAS types, + -- which has to have the flag Comes_From_Source for other purposes): + -- we assume that the expander will provide the missing completion. + elsif Ekind (E) = E_Function or else Ekind (E) = E_Procedure or else Ekind (E) = E_Generic_Function or else Ekind (E) = E_Generic_Procedure then if not Has_Completion (E) - and then not Is_Abstract (E) + and then not (Is_Subprogram (E) + and then Is_Abstract_Subprogram (E)) + and then not (Is_Subprogram (E) + and then + (not Comes_From_Source (E) + or else Chars (E) = Name_uCall)) and then Nkind (Parent (Unit_Declaration_Node (E))) /= N_Compilation_Unit and then Chars (E) /= Name_uSize @@ -8310,6 +8627,7 @@ package body Sem_Ch3 is -- a derivation from a private type) has no discriminants. -- (Defect Report 8652/0008, Technical Corrigendum 1, checked -- by ACATS B371001). + -- Rule updated for Ada 2005: the private type is said to have -- a constrained partial view, given that objects of the type -- can be declared. @@ -8401,12 +8719,19 @@ package body Sem_Ch3 is -- generic body, the rule is checked assuming that the actual type has -- defaulted discriminants. - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 or else Warn_On_Ada_2005_Compatibility then if Ekind (Base_Type (T)) = E_General_Access_Type and then Has_Defaulted_Discriminants (Desig_Type) then - Error_Msg_N - ("access subype of general access type not allowed", S); + if Ada_Version < Ada_05 then + Error_Msg_N + ("access subtype of general access type would not " & + "be allowed in Ada 2005?", S); + else + Error_Msg_N + ("access subype of general access type not allowed", S); + end if; + Error_Msg_N ("\discriminants have defaults", S); elsif Is_Access_Type (T) @@ -8414,7 +8739,15 @@ package body Sem_Ch3 is and then Has_Discriminants (Desig_Type) and then In_Package_Body (Current_Scope) then - Error_Msg_N ("access subtype not allowed in generic body", S); + if Ada_Version < Ada_05 then + Error_Msg_N + ("access subtype would not be allowed in generic body " & + "in Ada 2005?", S); + else + Error_Msg_N + ("access subtype not allowed in generic body", S); + end if; + Error_Msg_N ("\designated type is a discriminated formal", S); end if; @@ -9648,6 +9981,10 @@ package body Sem_Ch3 is Set_Is_Public (Full, Is_Public (Priv)); Set_Is_Pure (Full, Is_Pure (Priv)); Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); + Set_Has_Pragma_Unreferenced_Objects + (Full, Has_Pragma_Unreferenced_Objects + (Priv)); Conditional_Delay (Full, Priv); @@ -10379,7 +10716,13 @@ package body Sem_Ch3 is Subp := Node (Elmt); Iface := Find_Dispatching_Type (Subp); - if not Is_Ancestor (Iface, Tagged_Type) then + if Is_Concurrent_Record_Type (Tagged_Type) then + if not Present (Abstract_Interface_Alias (Subp)) then + Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); + Append_Elmt (New_Subp, Ifaces_List); + end if; + + elsif not Is_Parent (Iface, Tagged_Type) then Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); Append_Elmt (New_Subp, Ifaces_List); end if; @@ -10441,7 +10784,8 @@ package body Sem_Ch3 is Set_Is_Hidden (Iface_Subp); Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp)); Set_Alias (Iface_Subp, E); - Set_Is_Abstract (Iface_Subp, Is_Abstract (E)); + Set_Is_Abstract_Subprogram (Iface_Subp, + Is_Abstract_Subprogram (E)); Remove_Homonym (Iface_Subp); Next_Elmt (Elmt); @@ -10527,7 +10871,6 @@ package body Sem_Ch3 is procedure Replace_Type (Id, New_Id : Entity_Id) is Acc_Type : Entity_Id; - IR : Node_Id; Par : constant Node_Id := Parent (Derived_Type); begin @@ -10578,10 +10921,7 @@ package body Sem_Ch3 is Set_Scope (New_Id, New_Subp); -- Create a reference to it - - IR := Make_Itype_Reference (Sloc (Parent (Derived_Type))); - Set_Itype (IR, Acc_Type); - Insert_After (Parent (Derived_Type), IR); + Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); else Set_Etype (New_Id, Etype (Id)); @@ -10802,16 +11142,42 @@ package body Sem_Ch3 is -- function is not abstract unless the actual is. if Is_Generic_Type (Derived_Type) - and then not Is_Abstract (Derived_Type) + and then not Is_Abstract_Type (Derived_Type) then null; - elsif Is_Abstract (Alias (New_Subp)) - or else (Is_Tagged_Type (Derived_Type) - and then Etype (New_Subp) = Derived_Type - and then No (Actual_Subp)) + -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" + -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + + elsif Ada_Version >= Ada_05 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then not Is_Null_Extension (Derived_Type)) + or else (Is_Tagged_Type (Derived_Type) + and then Ekind (Etype (New_Subp)) = + E_Anonymous_Access_Type + and then Designated_Type (Etype (New_Subp)) = + Derived_Type + and then not Is_Null_Extension (Derived_Type))) + and then No (Actual_Subp) + then + if not Is_Tagged_Type (Derived_Type) + or else Is_Abstract_Type (Derived_Type) + or else Is_Abstract_Subprogram (Alias (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + else + Set_Requires_Overriding (New_Subp); + end if; + + elsif Ada_Version < Ada_05 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then No (Actual_Subp))) then - Set_Is_Abstract (New_Subp); + Set_Is_Abstract_Subprogram (New_Subp); -- Finally, if the parent type is abstract we must verify that all -- inherited operations are either non-abstract or overridden, or @@ -10822,13 +11188,13 @@ package body Sem_Ch3 is -- the parent type, in which case the abstractness of the inherited -- operation is carried to the new subprogram. - elsif Is_Abstract (Parent_Type) + elsif Is_Abstract_Type (Parent_Type) and then not In_Open_Scopes (Scope (Parent_Type)) and then Is_Private_Overriding - and then Is_Abstract (Visible_Subp) + and then Is_Abstract_Subprogram (Visible_Subp) then Set_Alias (New_Subp, Visible_Subp); - Set_Is_Abstract (New_Subp); + Set_Is_Abstract_Subprogram (New_Subp); end if; New_Overloaded_Entity (New_Subp, Derived_Type); @@ -10918,7 +11284,7 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Add the derivation of an abstract -- interface primitive to the list of entities to which - -- we have to associate aliased entity. + -- we have to associate an aliased entity. if Ada_Version >= Ada_05 and then Is_Dispatching_Operation (Subp) @@ -10939,7 +11305,11 @@ package body Sem_Ch3 is Next_Elmt (Elmt); end loop; - Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); + if Ada_Version >= Ada_05 + and then Is_Tagged_Type (Derived_Type) + then + Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); + end if; end Derive_Subprograms; -------------------------------- @@ -11116,16 +11486,19 @@ package body Sem_Ch3 is null; elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) non-limited interface cannot" & - " inherit from protected interface", Indic); + Error_Msg_N + ("(Ada 2005) non-limited interface cannot " & + "inherit from protected interface", Indic); elsif Synchronized_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) non-limited interface cannot" & - " inherit from synchronized interface", Indic); + Error_Msg_N + ("(Ada 2005) non-limited interface cannot " & + "inherit from synchronized interface", Indic); elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) non-limited interface cannot" & - " inherit from task interface", Indic); + Error_Msg_N + ("(Ada 2005) non-limited interface cannot " & + "inherit from task interface", Indic); else null; @@ -11134,6 +11507,16 @@ package body Sem_Ch3 is end if; end if; + if Is_Tagged_Type (Parent_Type) + and then Is_Concurrent_Type (Parent_Type) + and then not Is_Interface (Parent_Type) + and then not Is_Completion + then + Error_Msg_N ("parent type of a record extension cannot be " & + "a synchronized tagged type (3.9.1 (3/1)", N); + return; + end if; + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor -- interfaces @@ -12681,21 +13064,24 @@ package body Sem_Ch3 is ----------------------- function Is_Null_Extension (T : Entity_Id) return Boolean is - Full_Type_Decl : constant Node_Id := Parent (T); - Full_Type_Defn : constant Node_Id := Type_Definition (Full_Type_Decl); - Comp_List : Node_Id; - First_Comp : Node_Id; + Type_Decl : constant Node_Id := Parent (T); + Comp_List : Node_Id; + First_Comp : Node_Id; begin - if not Is_Tagged_Type (T) - or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition + if Nkind (Type_Decl) /= N_Full_Type_Declaration + or else not Is_Tagged_Type (T) + or else Nkind (Type_Definition (Type_Decl)) /= + N_Derived_Type_Definition + or else No (Record_Extension_Part (Type_Definition (Type_Decl))) then return False; end if; - Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn)); + Comp_List := + Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); - if Present (Discriminant_Specifications (Full_Type_Decl)) then + if Present (Discriminant_Specifications (Type_Decl)) then return False; elsif Present (Comp_List) @@ -12956,7 +13342,7 @@ package body Sem_Ch3 is Set_Ekind (CW_Type, E_Class_Wide_Type); Set_Is_Tagged_Type (CW_Type, True); Set_Primitive_Operations (CW_Type, New_Elmt_List); - Set_Is_Abstract (CW_Type, False); + Set_Is_Abstract_Type (CW_Type, False); Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); Init_Size_Align (CW_Type); @@ -13705,8 +14091,7 @@ package body Sem_Ch3 is (Discriminant_Type (Discr))) then Discr_Type := - Replace_Anonymous_Access_To_Protected_Subprogram - (Discr, Discr_Type); + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); end if; else @@ -14080,7 +14465,9 @@ package body Sem_Ch3 is ("completion of nonlimited type cannot be limited", Full_T); Explain_Limited_Type (Full_T, Full_T); - elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then + elsif Is_Abstract_Type (Full_T) + and then not Is_Abstract_Type (Priv_T) + then Error_Msg_N ("completion of nonabstract type cannot be abstract", Full_T); @@ -14105,13 +14492,12 @@ package body Sem_Ch3 is -- Check that ancestor interfaces of private and full views are -- consistent. We omit this check for synchronized types because - -- they are performed on thecorresponding record type when frozen. + -- they are performed on the corresponding record type when frozen. if Ada_Version >= Ada_05 and then Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) - and then Ekind (Full_T) /= E_Task_Type - and then Ekind (Full_T) /= E_Protected_Type + and then not Is_Concurrent_Type (Full_T) then declare Iface : Entity_Id; @@ -14309,8 +14695,7 @@ package body Sem_Ch3 is if Ada_Version >= Ada_05 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration and then Synchronized_Present (Parent (Priv_T)) - and then Ekind (Full_T) /= E_Task_Type - and then Ekind (Full_T) /= E_Protected_Type + and then not Is_Concurrent_Type (Full_T) then Error_Msg_N ("full view of synchronized extension must " & "be synchronized type", N); @@ -14374,8 +14759,7 @@ package body Sem_Ch3 is -- operations from the private view to the full view. if Is_Tagged_Type (Full_T) - and then Ekind (Full_T) /= E_Task_Type - and then Ekind (Full_T) /= E_Protected_Type + and then not Is_Concurrent_Type (Full_T) then declare Priv_List : Elist_Id; @@ -15079,6 +15463,15 @@ package body Sem_Ch3 is when Access_Kind => Constrain_Access (Def_Id, S, Related_Nod); + if Expander_Active + and then Is_Itype (Designated_Type (Def_Id)) + and then Nkind (Related_Nod) = N_Subtype_Declaration + and then not Is_Incomplete_Type (Designated_Type (Def_Id)) + then + Build_Itype_Reference + (Designated_Type (Def_Id), Related_Nod); + end if; + when Array_Kind => Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); @@ -15142,13 +15535,7 @@ package body Sem_Ch3 is and then Nkind (Parent (P)) = N_Full_Type_Declaration then - declare - Ref_Node : Node_Id; - begin - Ref_Node := Make_Itype_Reference (Sloc (Related_Nod)); - Set_Itype (Ref_Node, Def_Id); - Insert_After (Parent (P), Ref_Node); - end; + Build_Itype_Reference (Def_Id, Parent (P)); end if; else @@ -15172,274 +15559,317 @@ package body Sem_Ch3 is end if; end Process_Subtype; - ----------------------------- - -- Record_Type_Declaration -- - ----------------------------- + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- - procedure Record_Type_Declaration - (T : Entity_Id; - N : Node_Id; - Prev : Entity_Id) + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Def : constant Node_Id := Type_Definition (N); - Inc_T : Entity_Id := Empty; - - Is_Tagged : Boolean; - Tag_Comp : Entity_Id; - - procedure Check_Anonymous_Access_Types (Comp_List : Node_Id); - -- Ada 2005 AI-382: an access component in a record declaration can - -- refer to the enclosing record, in which case it denotes the type - -- itself, and not the current instance of the type. We create an - -- anonymous access type for the component, and flag it as an access - -- to a component, so that accessibility checks are properly performed - -- on it. The declaration of the access type is placed ahead of that - -- of the record, to prevent circular order-of-elaboration issues in - -- Gigi. We create an incomplete type for the record declaration, which - -- is the designated type of the anonymous access. - - procedure Make_Incomplete_Type_Declaration; + Loc : constant Source_Ptr := Sloc (Typ_Decl); + Anon_Access : Entity_Id; + Acc_Def : Node_Id; + Comp : Node_Id; + Comp_Def : Node_Id; + Decl : Node_Id; + Type_Def : Node_Id; + + procedure Build_Incomplete_Type_Declaration; -- If the record type contains components that include an access to the - -- current record, create an incomplete type declaration for the record, - -- to be used as the designated type of the anonymous access. This is - -- done only once, and only if there is no previous partial view of the - -- type. - - ---------------------------------- - -- Check_Anonymous_Access_Types -- - ---------------------------------- + -- current record, then create an incomplete type declaration for the + -- record, to be used as the designated type of the anonymous access. + -- This is done only once, and only if there is no previous partial + -- view of the type. + + function Mentions_T (Acc_Def : Node_Id) return Boolean; + -- Check whether an access definition includes a reference to + -- the enclosing record type. The reference can be a subtype + -- mark in the access definition itself, or a 'Class attribute + -- reference, or recursively a reference appearing in a parameter + -- type in an access_to_subprogram definition. - procedure Check_Anonymous_Access_Types (Comp_List : Node_Id) is - Anon_Access : Entity_Id; - Acc_Def : Node_Id; - Comp : Node_Id; - Comp_Def : Node_Id; - Decl : Node_Id; - Type_Def : Node_Id; + -------------------------------------- + -- Build_Incomplete_Type_Declaration -- + -------------------------------------- - function Mentions_T (Acc_Def : Node_Id) return Boolean; - -- Check whether an access definition includes a reference to - -- the enclosing record type. The reference can be a subtype - -- mark in the access definition itself, or a 'Class attribute - -- reference, or recursively a reference appearing in a parameter - -- type in an access_to_subprogram definition. + procedure Build_Incomplete_Type_Declaration is + Decl : Node_Id; + Inc_T : Entity_Id; + H : Entity_Id; - ---------------- - -- Mentions_T -- - ---------------- + begin + -- If there is a previous partial view, no need to create a new one + -- If the partial view, given by Prev, is incomplete, If Prev is + -- a private declaration, full declaration is flagged accordingly. - function Mentions_T (Acc_Def : Node_Id) return Boolean is - Subt : Node_Id; + if Prev /= Typ then + if Tagged_Present (Type_Definition (Typ_Decl)) then + Make_Class_Wide_Type (Prev); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; - begin - if No (Access_To_Subprogram_Definition (Acc_Def)) then - Subt := Subtype_Mark (Acc_Def); + return; - if Nkind (Subt) = N_Identifier then - return Chars (Subt) = Chars (T); + elsif Has_Private_Declaration (Typ) then + return; - -- A reference to the current type may appear as the prefix - -- of a 'Class attribute. + -- If there was a previous anonymous access type, the incomplete + -- type declaration will have been created already. - elsif Nkind (Subt) = N_Attribute_Reference - and then Attribute_Name (Subt) = Name_Class - and then Is_Entity_Name (Prefix (Subt)) - then - return (Chars (Prefix (Subt))) = Chars (T); - else - return False; - end if; + elsif Present (Current_Entity (Typ)) + and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type + and then Full_View (Current_Entity (Typ)) = Typ + then + return; - else - -- Component is an access_to_subprogram: examine its formals + else + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - declare - Param_Spec : Node_Id; + -- Type has already been inserted into the current scope. + -- Remove it, and add incomplete declaration for type, so + -- that subsequent anonymous access types can use it. + -- The entity is unchained from the homonym list and from + -- immediate visibility. After analysis, the entity in the + -- incomplete declaration becomes immediately visible in the + -- record declaration that follows. - begin - Param_Spec := - First - (Parameter_Specifications - (Access_To_Subprogram_Definition (Acc_Def))); - while Present (Param_Spec) loop - if Nkind (Parameter_Type (Param_Spec)) - = N_Access_Definition - and then Mentions_T (Parameter_Type (Param_Spec)) - then - return True; - end if; + H := Current_Entity (Typ); - Next (Param_Spec); - end loop; + if H = Typ then + Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); + else + while Present (H) + and then Homonym (H) /= Typ + loop + H := Homonym (Typ); + end loop; - return False; - end; + Set_Homonym (H, Homonym (Typ)); end if; - end Mentions_T; - - -- Start of processing for Check_Anonymous_Access_Types - begin - if No (Comp_List) then - return; - end if; + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, Typ); - Comp := First (Component_Items (Comp_List)); - while Present (Comp) loop - if Nkind (Comp) = N_Component_Declaration - and then Present - (Access_Definition (Component_Definition (Comp))) - and then - Mentions_T (Access_Definition (Component_Definition (Comp))) + if (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present + (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else Tagged_Present (Type_Definition (Typ_Decl)) then - Comp_Def := Component_Definition (Comp); - Acc_Def := - Access_To_Subprogram_Definition - (Access_Definition (Comp_Def)); + -- Create a common class-wide type for both views, and set + -- the etype of the class-wide type to the full view. - Make_Incomplete_Type_Declaration; - Anon_Access := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. - - if Present (Acc_Def) then - if Nkind (Acc_Def) = N_Access_Function_Definition then - Type_Def := - Make_Access_Function_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def), - Result_Definition => Result_Definition (Acc_Def)); - else - Type_Def := - Make_Access_Procedure_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def)); - end if; + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; + end if; + end Build_Incomplete_Type_Declaration; - else - Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - Relocate_Node - (Subtype_Mark - (Access_Definition (Comp_Def)))); - end if; + ---------------- + -- Mentions_T -- + ---------------- - Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Subt : Node_Id; + Type_Id : constant Name_Id := Chars (Typ); - Insert_Before (N, Decl); - Analyze (Decl); + begin + if No (Access_To_Subprogram_Definition (Acc_Def)) then + Subt := Subtype_Mark (Acc_Def); - -- If an access to object, Preserve entity of designated type, - -- for ASIS use, before rewriting the component definition. + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; - if No (Acc_Def) then - declare - Desig : Entity_Id; + -- Reference can be through an expanded name which has not been + -- analyzed yet, and designates enclosing scopes. - begin - Desig := Entity (Subtype_Indication (Type_Def)); + elsif Nkind (Subt) = N_Selected_Component then + Analyze (Prefix (Subt)); - -- If the access definition is to the current record, - -- the visible entity at this point is an incomplete - -- type. Retrieve the full view to simplify ASIS queries + if Chars (Selector_Name (Subt)) = Type_Id then + return Is_Entity_Name (Prefix (Subt)) + and then Entity (Prefix (Subt)) = Current_Scope; - if Ekind (Desig) = E_Incomplete_Type then - Desig := Full_View (Desig); - end if; + -- The access definition may name a subtype of the enclosing + -- type, if there is a previous incomplete declaration for it. - Set_Entity - (Subtype_Mark (Access_Definition (Comp_Def)), Desig); - end; + else + Find_Selected_Component (Subt); + return + Is_Entity_Name (Subt) + and then Scope (Entity (Subt)) = Current_Scope + and then (Chars (Base_Type (Entity (Subt))) = Type_Id + or else + (Is_Class_Wide_Type (Entity (Subt)) + and then + Chars (Etype (Base_Type (Entity (Subt)))) + = Type_Id)); end if; - Rewrite (Comp_Def, - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); - Set_Is_Local_Anonymous_Access (Anon_Access); + -- A reference to the current type may appear as the prefix of + -- a 'Class attribute. + + elsif Nkind (Subt) = N_Attribute_Reference + and then Attribute_Name (Subt) = Name_Class + and then Is_Entity_Name (Prefix (Subt)) + then + return (Chars (Prefix (Subt))) = Type_Id; + else + return False; end if; - Next (Comp); - end loop; + else + -- Component is an access_to_subprogram: examine its formals - if Present (Variant_Part (Comp_List)) then declare - V : Node_Id; + Param_Spec : Node_Id; + begin - V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - while Present (V) loop - Check_Anonymous_Access_Types (Component_List (V)); - Next_Non_Pragma (V); + Param_Spec := + First + (Parameter_Specifications + (Access_To_Subprogram_Definition (Acc_Def))); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) + = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; + end if; + + Next (Param_Spec); end loop; + + return False; end; end if; - end Check_Anonymous_Access_Types; + end Mentions_T; - -------------------------------------- - -- Make_Incomplete_Type_Declaration -- - -------------------------------------- + -- Start of processing for Check_Anonymous_Access_Components - procedure Make_Incomplete_Type_Declaration is - Decl : Node_Id; - H : Entity_Id; - - begin - -- If there is a previous partial view, no need to create a new one - -- If the partial view is incomplete, it is given by Prev. If it is - -- a private declaration, full declaration is flagged accordingly. + begin + if No (Comp_List) then + return; + end if; - if Prev /= T - or else Has_Private_Declaration (T) + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Present + (Access_Definition (Component_Definition (Comp))) + and then + Mentions_T (Access_Definition (Component_Definition (Comp))) then - return; + Comp_Def := Component_Definition (Comp); + Acc_Def := + Access_To_Subprogram_Definition + (Access_Definition (Comp_Def)); - elsif No (Inc_T) then - Inc_T := Make_Defining_Identifier (Loc, Chars (T)); - Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + Build_Incomplete_Type_Declaration; + Anon_Access := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); - -- Type has already been inserted into the current scope. - -- Remove it, and add incomplete declaration for type, so - -- that subsequent anonymous access types can use it. - -- The entity is unchained from the homonym list and from - -- immediate visibility. After analysis, the entity in the - -- incomplete declaration becomes immediately visible in the - -- record declaration that follows. + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. - H := Current_Entity (T); + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); + else + Type_Def := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); + end if; - if H = T then - Set_Name_Entity_Id (Chars (T), Homonym (T)); else - while Present (H) - and then Homonym (H) /= T - loop - H := Homonym (T); - end loop; - - Set_Homonym (H, Homonym (T)); + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node + (Subtype_Mark + (Access_Definition (Comp_Def)))); end if; - Insert_Before (N, Decl); + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); + + Insert_Before (Typ_Decl, Decl); Analyze (Decl); - Set_Full_View (Inc_T, T); - if Tagged_Present (Def) then - Make_Class_Wide_Type (Inc_T); - Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T)); - Set_Etype (Class_Wide_Type (T), T); + -- If an access to object, Preserve entity of designated type, + -- for ASIS use, before rewriting the component definition. + + if No (Acc_Def) then + declare + Desig : Entity_Id; + + begin + Desig := Entity (Subtype_Indication (Type_Def)); + + -- If the access definition is to the current record, + -- the visible entity at this point is an incomplete + -- type. Retrieve the full view to simplify ASIS queries + + if Ekind (Desig) = E_Incomplete_Type then + Desig := Full_View (Desig); + end if; + + Set_Entity + (Subtype_Mark (Access_Definition (Comp_Def)), Desig); + end; end if; + + Rewrite (Comp_Def, + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Anon_Access, Loc))); + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + Set_Is_Local_Anonymous_Access (Anon_Access); end if; - end Make_Incomplete_Type_Declaration; - -- Start of processing for Record_Type_Declaration + Next (Comp); + end loop; + + if Present (Variant_Part (Comp_List)) then + declare + V : Node_Id; + begin + V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (V) loop + Check_Anonymous_Access_Components + (Typ_Decl, Typ, Prev, Component_List (V)); + Next_Non_Pragma (V); + end loop; + end; + end if; + end Check_Anonymous_Access_Components; + + ----------------------------- + -- Record_Type_Declaration -- + ----------------------------- + + procedure Record_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Prev : Entity_Id) + is + Def : constant Node_Id := Type_Definition (N); + Is_Tagged : Boolean; + Tag_Comp : Entity_Id; begin -- These flags must be initialized before calling Process_Discriminants @@ -15471,7 +15901,7 @@ package body Sem_Ch3 is -- Type is abstract if full declaration carries keyword, or if -- previous partial view did. - Set_Is_Abstract (T, Is_Abstract (T) + Set_Is_Abstract_Type (T, Is_Abstract_Type (T) or else Abstract_Present (Def)); else @@ -15490,100 +15920,17 @@ package body Sem_Ch3 is -- create the required anonymous access type declarations, and if -- need be an incomplete type declaration for T itself. - Check_Anonymous_Access_Types (Component_List (Def)); + Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then + Check_Abstract_Interfaces (N, Def); + declare - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; Ifaces_List : Elist_Id; begin - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - Iface_Def := Type_Definition (Parent (Iface_Typ)); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - -- "The declaration of a specific descendant of an - -- interface type freezes the interface type" RM 13.14 - - Freeze_Before (N, Iface_Typ); - - -- Ada 2005 (AI-345): Protected interfaces can only - -- inherit from limited, synchronized or protected - -- interfaces. - - if Protected_Present (Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot" - & " inherit from task interface", Iface); - - else - Error_Msg_N ("(Ada 2005) protected interface cannot" - & " inherit from non-limited interface", Iface); - end if; - - -- Ada 2005 (AI-345): Synchronized interfaces can only - -- inherit from limited and synchronized. - - elsif Synchronized_Present (Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) synchronized interface " & - "cannot inherit from protected interface", Iface); - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) synchronized interface " & - "cannot inherit from task interface", Iface); - - else - Error_Msg_N ("(Ada 2005) synchronized interface " & - "cannot inherit from non-limited interface", - Iface); - end if; - - -- Ada 2005 (AI-345): Task interfaces can only inherit - -- from limited, synchronized or task interfaces. - - elsif Task_Present (Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Task_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot" & - " inherit from protected interface", Iface); - - else - Error_Msg_N ("(Ada 2005) task interface cannot" & - " inherit from non-limited interface", Iface); - end if; - end if; - end if; - - Next (Iface); - end loop; - -- Ada 2005 (AI-251): Collect the list of progenitors that are not -- already in the parents. @@ -15637,9 +15984,11 @@ package body Sem_Ch3 is Init_Component_Location (Tag_Comp); -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the - -- implemented interfaces + -- implemented interfaces. - Add_Interface_Tag_Components (N, T); + if Has_Abstract_Interfaces (T) then + Add_Interface_Tag_Components (N, T); + end if; end if; Make_Class_Wide_Type (T); @@ -15732,8 +16081,8 @@ package body Sem_Ch3 is end if; -- After completing the semantic analysis of the record definition, - -- record components, both new and inherited, are accessible. Set - -- their kind accordingly. + -- record components, both new and inherited, are accessible. Set their + -- kind accordingly. Component := First_Entity (Current_Scope); while Present (Component) loop @@ -15762,8 +16111,8 @@ package body Sem_Ch3 is Next_Entity (Component); end loop; - -- A type is Finalize_Storage_Only only if all its controlled - -- components are so. + -- A Type is Finalize_Storage_Only only if all its controlled components + -- are also. if Ctrl_Components then Set_Finalize_Storage_Only (T, Final_Storage_Only); @@ -15880,7 +16229,6 @@ package body Sem_Ch3 is Make_Range (Loc, Low_Bound => Make_Real_Literal (Loc, Lo), High_Bound => Make_Real_Literal (Loc, Hi)); - begin Set_Scalar_Range (E, S); Set_Parent (S, E); @@ -15916,7 +16264,6 @@ package body Sem_Ch3 is Set_Ekind (Def_Id, E_Void); Process_Range_Expr_In_Decl (R, Subt); Set_Ekind (Def_Id, Kind); - end Set_Scalar_Range_For_Subtype; -------------------------------------------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index ebdb2095422..2d5fabce206 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -246,14 +246,12 @@ package Sem_Ch3 is -- Prev is entity on the partial view, on which references are posted. function Replace_Anonymous_Access_To_Protected_Subprogram - (N : Node_Id; - Prev_E : Entity_Id) return Entity_Id; + (N : Node_Id) return Entity_Id; -- Ada 2005 (AI-254): Create and decorate an internal full type declaration - -- in the enclosing scope corresponding to an anonymous access to protected - -- subprogram. In addition, replace the anonymous access by an occurrence - -- of this internal type. Prev_Etype is used to link the new internal - -- entity with the anonymous entity. Return the entity of this type - -- declaration. + -- for an anonymous access to protected subprogram. For a record component + -- declaration, the type is created in the enclosing scope, for an array + -- type declaration or an object declaration it is simply placed ahead of + -- this declaration. procedure Set_Completion_Referenced (E : Entity_Id); -- If E is the completion of a private or incomplete type declaration,