From 2b73cf6852765d6fc6034577369fc90524987a8c Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 6 Jun 2007 12:39:14 +0200 Subject: [PATCH] sem_ch3.adb (Process_Full_View): Propagate the CPP_Class attribute to the full type declaration. 2007-04-20 Javier Miranda Hristian Kirtchev Ed Schonberg * sem_ch3.adb (Process_Full_View): Propagate the CPP_Class attribute to the full type declaration. (Analyze_Component_Declaration): Add local variable E to capture the initialization expression of the declaration. Replace the occurences of Expression (N) with E. (OK_For_Limited_Init_In_05): Allow initialization of class-wide limited interface object with a function call. (Array_Type_Declaration): If the declaration lacks subtype marks for indices, create a simple index list to prevent cascaded errors. (Is_Null_Extension): Ignore internal components created for secondary tags when checking whether a record extension is a null extension. (Check_Abstract_Interfaces): Add missing support for interface subtypes and generic formals. (Derived_Type_Declaration): Add missing support for interface subtypes and generic formals. (Analyze_Object_Declaration): If an initialization expression is present, traverse its subtree and mark all allocators as static coextensions. (Add_Interface_Tag_Component): When looking for components that may be secondary tags, ignore pragmas that can appear within a record declaration. (Check_Abstract_Overriding): an inherited function that dispatches on result does not need to be overriden if the controlling type is a null extension. (Mentions_T): Handle properly a 'class attribute in an anonymous access component declaration, when the prefix is an expanded name. (Inherit_Component): If the derivation is for a private extension, inherited components remain visible and their ekind should not be set to Void. (Find_Type_Of_Object): In the case of an access definition, always set Is_Local_Anonymous_Access. We were previously not marking the anonymous access type of a return object as a local anonymous type. (Make_Index): Use Ambiguous_Character to report ambiguity on a discrete range with character literal bounds. (Constrain_Array): Initialize the Packed_Array_Type field to Empty. (Access_Subprogram_Declaration): Indicate that the type declaration depends on an incomplete type only if the incomplete type is declared in an open scope. (Analyze_Subtype_Declaration): Handle properly subtypes of synchronized types that are tagged, and that may appear as generic actuals. (Access_Subprogram_Declaration): An anonymous access to subprogram can appear as an access discriminant in a private type declaration. (Add_Interface_Tag_Components): Complete decoration of the component containing the tag of a secondary dispatch table and the component containing the offset to the base of the object (this latter component is only generated when the parent type has discriminants --as documented in this routine). (Inherit_Components): Use the new decoration of the tag components to improve the condition that avoids inheriting the components associated with secondary tags of the parent. (Build_Discriminanted_Subtype): Indicate to the backend that the size of record types associated with dispatch tables is known at compile time. (Analyze_Subtype_Declaration): Propagate Is_Interface flag when needed. (Analyze_Interface_Declaration): Change setting of Is_Limited_Interface to include task, protected, and synchronized interfaces as limited interfaces. (Process_Discriminants): Remove the setting of Is_Local_Anonymous_Access on the type of (anonymous) access discriminants of nonlimited types. (Analyze_Interface_Type_Declaration): Complete the decoration of the class-wide entity it is is already present. This situation occurs if the limited-view has been previously built. (Enumeration_Type_Declaration): Initialize properly the Enum_Pos_To_Rep field. (Add_Interface_Tag_Components.Add_Tag): Set the value of the attribute Related_Interface. From-SVN: r125437 --- gcc/ada/sem_ch3.adb | 738 ++++++++++++++++++++++++++++++-------------- 1 file changed, 511 insertions(+), 227 deletions(-) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 71afa7d1813..f72104c5e46 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -184,16 +184,15 @@ package body Sem_Ch3 is (T : Entity_Id; Def : Node_Id; Derived_Def : Boolean := False) return Elist_Id; - -- Validate discriminant constraints, and return the list of the - -- constraints in order of discriminant declarations. T is the - -- discriminated unconstrained type. Def is the N_Subtype_Indication node - -- where the discriminants constraints for T are specified. Derived_Def is - -- True if we are building the discriminant constraints in a derived type - -- definition of the form "type D (...) is new T (xxx)". In this case T is - -- the parent type and Def is the constraint "(xxx)" on T and this routine - -- sets the Corresponding_Discriminant field of the discriminants in the - -- derived type D to point to the corresponding discriminants in the parent - -- type T. + -- Validate discriminant constraints and return the list of the constraints + -- in order of discriminant declarations, where T is the discriminated + -- unconstrained type. Def is the N_Subtype_Indication node where the + -- discriminants constraints for T are specified. Derived_Def is True + -- when building the discriminant constraints in a derived type definition + -- of the form "type D (...) is new T (xxx)". In this case T is the parent + -- type and Def is the constraint "(xxx)" on T and this routine sets the + -- Corresponding_Discriminant field of the discriminants in the derived + -- type D to point to the corresponding discriminants in the parent type T. procedure Build_Discriminated_Subtype (T : Entity_Id; @@ -706,6 +705,7 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (Related_Nod); Anon_Type : Entity_Id; + Anon_Scope : Entity_Id; Desig_Type : Entity_Id; Decl : Entity_Id; @@ -727,10 +727,7 @@ package body Sem_Ch3 is if Nkind (Related_Nod) = N_Object_Declaration or else Nkind (Related_Nod) = N_Access_Function_Definition then - Anon_Type := - Create_Itype - (E_Anonymous_Access_Type, Related_Nod, - Scope_Id => Current_Scope); + Anon_Scope := Current_Scope; -- For the anonymous function result case, retrieve the scope of the -- function specification's associated entity rather than using the @@ -743,22 +740,28 @@ package body Sem_Ch3 is 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_Entity (Related_Nod))); + -- If the current scope is a protected type, the anonymous access + -- is associated with one of the protected operations, and must + -- be available in the scope that encloses the protected declaration. + -- Otherwise the type is is in the scope enclosing the subprogram. + + if Ekind (Current_Scope) = E_Protected_Type then + Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod))); + else + Anon_Scope := Scope (Defining_Entity (Related_Nod)); + end if; else -- For access formals, access components, and access discriminants, -- the scope is that of the enclosing declaration, - Anon_Type := - Create_Itype - (E_Anonymous_Access_Type, Related_Nod, - Scope_Id => Scope (Current_Scope)); + Anon_Scope := Scope (Current_Scope); end if; + Anon_Type := + Create_Itype + (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); + if All_Present (N) and then Ada_Version >= Ada_05 then @@ -781,6 +784,14 @@ package body Sem_Ch3 is (Anon_Type, E_Anonymous_Access_Subprogram_Type); end if; + -- If the anonymous access is associated with a protected operation + -- create a reference to it after the enclosing protected definition + -- because the itype will be used in the subsequent bodies. + + if Ekind (Current_Scope) = E_Protected_Type then + Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); + end if; + return Anon_Type; end if; @@ -810,7 +821,7 @@ package body Sem_Ch3 is Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the - -- designated type comes from the limited view (for back-end purposes). + -- designated type comes from the limited view. Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type)); @@ -917,6 +928,8 @@ package body Sem_Ch3 is D_Ityp := Associated_Node_For_Itype (Desig_Type); while Nkind (D_Ityp) /= N_Full_Type_Declaration + and then Nkind (D_Ityp) /= N_Private_Type_Declaration + and then Nkind (D_Ityp) /= N_Private_Extension_Declaration and then Nkind (D_Ityp) /= N_Procedure_Specification and then Nkind (D_Ityp) /= N_Function_Specification and then Nkind (D_Ityp) /= N_Object_Declaration @@ -944,9 +957,27 @@ package body Sem_Ch3 is if Nkind (T_Def) = N_Access_Function_Definition then if Nkind (Result_Definition (T_Def)) = N_Access_Definition then - Set_Etype - (Desig_Type, - Access_Definition (T_Def, Result_Definition (T_Def))); + + declare + Acc : constant Node_Id := Result_Definition (T_Def); + + begin + if Present (Access_To_Subprogram_Definition (Acc)) + and then + Protected_Present (Access_To_Subprogram_Definition (Acc)) + then + Set_Etype + (Desig_Type, + Replace_Anonymous_Access_To_Protected_Subprogram + (T_Def)); + + else + Set_Etype + (Desig_Type, + Access_Definition (T_Def, Result_Definition (T_Def))); + end if; + end; + else Analyze (Result_Definition (T_Def)); Set_Etype (Desig_Type, Entity (Result_Definition (T_Def))); @@ -963,7 +994,7 @@ package body Sem_Ch3 is end if; if Present (Formals) then - New_Scope (Desig_Type); + Push_Scope (Desig_Type); Process_Formals (Formals, Parent (T_Def)); -- A bit of a kludge here, End_Scope requires that the parent @@ -979,7 +1010,9 @@ package body Sem_Ch3 is -- The return type and/or any parameter type may be incomplete. Mark -- the subprogram_type as depending on the incomplete type, so that - -- it can be updated when the full type declaration is seen. + -- it can be updated when the full type declaration is seen. This + -- only applies to incomplete types declared in some enclosing scope, + -- not to limited views from other packages. if Present (Formals) then Formal := First_Formal (Desig_Type); @@ -990,7 +1023,9 @@ package body Sem_Ch3 is Error_Msg_N ("functions can only have IN parameters", Formal); end if; - if Ekind (Etype (Formal)) = E_Incomplete_Type then + if Ekind (Etype (Formal)) = E_Incomplete_Type + and then In_Open_Scopes (Scope (Etype (Formal))) + then Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); Set_Has_Delayed_Freeze (Desig_Type); end if; @@ -1088,8 +1123,6 @@ package body Sem_Ch3 is Init_Size_Align (T); end if; - Set_Is_Access_Constant (T, Constant_Present (Def)); - Desig := Designated_Type (T); -- If designated type is an imported tagged type, indicate that the @@ -1100,30 +1133,11 @@ package body Sem_Ch3 is -- is available, use it as the designated type of the access type, so -- that the back-end gets a usable entity. - declare - N_Desig : Entity_Id; - - begin - if From_With_Type (Desig) - and then Ekind (Desig) /= E_Access_Type - then - Set_From_With_Type (T); - - if Is_Incomplete_Type (Desig) then - N_Desig := Non_Limited_View (Desig); - - else pragma Assert (Ekind (Desig) = E_Class_Wide_Type); - if From_With_Type (Etype (Desig)) then - N_Desig := Non_Limited_View (Etype (Desig)); - else - N_Desig := Etype (Desig); - end if; - end if; - - pragma Assert (Present (N_Desig)); - Set_Directly_Designated_Type (T, N_Desig); - end if; - end; + if From_With_Type (Desig) + and then Ekind (Desig) /= E_Access_Type + then + Set_From_With_Type (T); + end if; -- Note that Has_Task is always false, since the access type itself -- is not a task type. See Einfo for more description on this point. @@ -1206,8 +1220,9 @@ package body Sem_Ch3 is Set_Analyzed (Decl); Set_Ekind (Tag, E_Component); - Set_Is_Limited_Record (Tag); Set_Is_Tag (Tag); + Set_Is_Aliased (Tag); + Set_Related_Interface (Tag, Iface); Init_Component_Location (Tag); pragma Assert (Is_Frozen (Iface)); @@ -1248,6 +1263,8 @@ package body Sem_Ch3 is Set_Analyzed (Decl); Set_Ekind (Offset, E_Component); + Set_Is_Aliased (Offset); + Set_Related_Interface (Offset, Iface); Init_Component_Location (Offset); Insert_After (Last_Tag, Decl); Last_Tag := Decl; @@ -1261,8 +1278,14 @@ package body Sem_Ch3 is -- Start of processing for Add_Interface_Tag_Components begin + if not RTE_Available (RE_Interface_Tag) then + Error_Msg + ("(Ada 2005) interface types not supported by this run-time!", + Sloc (N)); + return; + end if; + if Ekind (Typ) /= E_Record_Type - 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) @@ -1306,7 +1329,9 @@ package body Sem_Ch3 is Comp := First (L); while Present (Comp) loop - if Is_Tag (Defining_Identifier (Comp)) then + if Nkind (Comp) = N_Component_Declaration + and then Is_Tag (Defining_Identifier (Comp)) + then Last_Tag := Comp; end if; @@ -1342,6 +1367,7 @@ package body Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); + E : constant Node_Id := Expression (N); T : Entity_Id; P : Entity_Id; @@ -1360,11 +1386,17 @@ package body Sem_Ch3 is function Contains_POC (Constr : Node_Id) return Boolean is begin + -- Prevent cascaded errors. + + if Error_Posted (Constr) then + return False; + end if; + case Nkind (Constr) is when N_Attribute_Reference => - return Attribute_Name (Constr) = Name_Access - and - Prefix (Constr) = Scope (Entity (Prefix (Constr))); + return + Attribute_Name (Constr) = Name_Access + and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); when N_Discriminant_Association => return Denotes_Discriminant (Expression (Constr)); @@ -1500,12 +1532,11 @@ package body Sem_Ch3 is -- "Handling of Default and Per-Object Expressions" in the spec of -- package Sem). - if Present (Expression (N)) then - Analyze_Per_Use_Expression (Expression (N), T); - Check_Initialization (T, Expression (N)); + if Present (E) then + Analyze_Per_Use_Expression (E, T); + Check_Initialization (T, E); if Ada_Version >= Ada_05 - and then Is_Access_Type (T) and then Ekind (T) = E_Anonymous_Access_Type then -- Check RM 3.9.2(9): "if the expected type for an expression is @@ -1518,25 +1549,35 @@ package body Sem_Ch3 is and then Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type and then - Ekind (Directly_Designated_Type (Etype (Expression (N)))) = - E_Class_Wide_Type + Ekind (Directly_Designated_Type (Etype (E))) = + E_Class_Wide_Type then Error_Msg_N ("access to specific tagged type required ('R'M 3.9.2(9))", - Expression (N)); + E); end if; -- (Ada 2005: AI-230): Accessibility check for anonymous -- components - -- Missing barrier Ada_Version >= Ada_05??? + if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then + Error_Msg_N + ("expression has deeper access level than component " & + "('R'M 3.10.2 (12.2))", E); + end if; + + -- The initialization expression is a reference to an access + -- discriminant. The type of the discriminant is always deeper + -- than any access type. - if Type_Access_Level (Etype (Expression (N))) > - Type_Access_Level (T) + if Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Is_Entity_Name (E) + and then Ekind (Entity (E)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (E))) then Error_Msg_N - ("expression has deeper access level than component " & - "('R'M 3.10.2 (12.2))", Expression (N)); + ("discriminant has deeper accessibility level than target", + E); end if; end if; end if; @@ -1813,7 +1854,7 @@ package body Sem_Ch3 is Set_Primitive_Operations (T, New_Elmt_List); end if; - New_Scope (T); + Push_Scope (T); Set_Stored_Constraint (T, No_Elist); @@ -1836,6 +1877,8 @@ package body Sem_Ch3 is ----------------------------------- procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is + CW : constant Entity_Id := Class_Wide_Type (T); + begin Set_Is_Tagged_Type (T); @@ -1844,18 +1887,45 @@ package body Sem_Ch3 is or else Protected_Present (Def) or else Synchronized_Present (Def)); - -- Type is abstract if full declaration carries keyword, or if - -- previous partial view did. + -- Type is abstract if full declaration carries keyword, or if previous + -- partial view did. Set_Is_Abstract_Type (T); Set_Is_Interface (T); - Set_Is_Limited_Interface (T, Limited_Present (Def)); + -- Type is a limited interface if it includes the keyword limited, task, + -- protected, or synchronized. + + Set_Is_Limited_Interface + (T, Limited_Present (Def) + or else Protected_Present (Def) + or else Synchronized_Present (Def) + or else Task_Present (Def)); + Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Synchronized_Interface (T, Synchronized_Present (Def)); Set_Is_Task_Interface (T, Task_Present (Def)); + + -- Type is a synchronized interface if it includes the keyword task, + -- protected, or synchronized. + + Set_Is_Synchronized_Interface + (T, Synchronized_Present (Def) + or else Protected_Present (Def) + or else Task_Present (Def)); + Set_Abstract_Interfaces (T, New_Elmt_List); Set_Primitive_Operations (T, New_Elmt_List); + + -- Complete the decoration of the class-wide entity if it was already + -- built (ie. during the creation of the limited view) + + if Present (CW) then + Set_Is_Interface (CW); + Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); + Set_Is_Protected_Interface (CW, Is_Protected_Interface (T)); + Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); + Set_Is_Task_Interface (CW, Is_Task_Interface (T)); + end if; end Analyze_Interface_Declaration; ----------------------------- @@ -2260,6 +2330,7 @@ package body Sem_Ch3 is -- Process initialization expression if present and not in error if Present (E) and then E /= Error then + Mark_Static_Coextensions (E); Analyze (E); -- In case of errors detected in the analysis of the expression, @@ -2288,6 +2359,7 @@ package body Sem_Ch3 is if not Assignment_OK (N) then Check_Initialization (T, E); end if; + Check_Unset_Reference (E); -- If this is a variable, then set current value @@ -3130,6 +3202,11 @@ package body Sem_Ch3 is Set_Primitive_Operations (Id, Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + + if Is_Interface (T) then + Set_Is_Interface (Id); + Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); + end if; end if; when Private_Kind => @@ -3205,6 +3282,7 @@ package body Sem_Ch3 is Set_First_Private_Entity (Id, First_Private_Entity (T)); Set_Has_Discriminants (Id, Has_Discriminants (T)); Set_Is_Constrained (Id, Is_Constrained (T)); + Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); Set_Last_Entity (Id, Last_Entity (T)); if Has_Discriminants (T) then @@ -3261,6 +3339,10 @@ package body Sem_Ch3 is Set_Is_Immediately_Visible (Id, True); Set_Depends_On_Private (Id, Has_Private_Component (T)); + if Is_Interface (T) then + Set_Is_Interface (Id); + end if; + if Present (Generic_Parent_Type (N)) and then (Nkind @@ -3270,7 +3352,14 @@ package body Sem_Ch3 is /= N_Formal_Private_Type_Definition) then if Is_Tagged_Type (Id) then - if Is_Class_Wide_Type (Id) then + + -- If this is a generic actual subtype for a synchronized type, + -- the primitive operations are those of the corresponding record + -- for which there is a separate subtype declaration. + + if Is_Concurrent_Type (Id) then + null; + elsif Is_Class_Wide_Type (Id) then Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); else Derive_Subprograms (Generic_Parent_Type (N), Id, T); @@ -3718,7 +3807,13 @@ package body Sem_Ch3 is Discr_Name := Name (N); Analyze (Discr_Name); - if Ekind (Entity (Discr_Name)) /= E_Discriminant then + if Etype (Discr_Name) = Any_Type then + + -- Prevent cascaded errors + + return; + + elsif Ekind (Entity (Discr_Name)) /= E_Discriminant then Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); end if; @@ -3964,7 +4059,7 @@ package body Sem_Ch3 is and then not Is_Itype (Element_Type) then Error_Msg_N - ("null-exclusion cannot be applied to a null excluding type", + ("`NOT NULL` not allowed (null already excluded)", Subtype_Indication (Component_Definition (Def))); end if; end if; @@ -3993,6 +4088,23 @@ package body Sem_Ch3 is end if; end if; + -- A syntax error in the declaration itself may lead to an empty + -- index list, in which case do a minimal patch. + + if No (First_Index (T)) then + Error_Msg_N ("missing index definition in array type declaration", T); + + declare + Indices : constant List_Id := + New_List (New_Occurrence_Of (Any_Id, Sloc (T))); + + begin + Set_Discrete_Subtype_Definitions (Def, Indices); + Set_First_Index (T, First (Indices)); + return; + end; + end if; + -- Create a concatenation operator for the new type. Internal -- array types created for packed entities do not need such, they -- are compatible with the user-defined type. @@ -4059,6 +4171,10 @@ package body Sem_Ch3 is Comp := Parameter_Type (N); Acc := Comp; + when N_Access_Function_Definition => + Comp := Result_Definition (N); + Acc := Comp; + when N_Object_Declaration => Comp := Object_Definition (N); Acc := Comp; @@ -4104,6 +4220,9 @@ package body Sem_Ch3 is Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); Set_Etype (Defining_Identifier (N), Anon); + elsif Nkind (N) = N_Access_Function_Definition then + Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); + else Rewrite (Comp, Make_Component_Definition (Loc, @@ -4115,12 +4234,16 @@ package body Sem_Ch3 is -- Temporarily remove the current scope from the stack to add the new -- declarations to the enclosing scope - if Nkind (N) /= N_Object_Declaration then - Scope_Stack.Decrement_Last; + if Nkind (N) = N_Object_Declaration + or else Nkind (N) = N_Access_Function_Definition + then Analyze (Decl); - Scope_Stack.Append (Curr_Scope); + else + Scope_Stack.Decrement_Last; Analyze (Decl); + Set_Is_Itype (Anon); + Scope_Stack.Append (Curr_Scope); end if; Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); @@ -4356,7 +4479,7 @@ package body Sem_Ch3 is end if; if Present (Discriminant_Specifications (N)) then - New_Scope (Derived_Type); + Push_Scope (Derived_Type); Check_Or_Process_Discriminants (N, Derived_Type); End_Scope; @@ -6170,15 +6293,15 @@ package body Sem_Ch3 is -- be limited in that case the type must be explicitly declared as -- limited. - Set_Is_Tagged_Type (Derived_Type, Is_Tagged); - Set_Is_Limited_Record (Derived_Type, - Limited_Present (Type_Def) - or else (Is_Limited_Record (Parent_Type) - and then not Is_Interface (Parent_Type))); + Set_Is_Limited_Record + (Derived_Type, + Limited_Present (Type_Def) + or else (Is_Limited_Record (Parent_Type) + and then not Is_Interface (Parent_Type))); -- STEP 2a: process discriminants of derived type if any - New_Scope (Derived_Type); + Push_Scope (Derived_Type); if Discriminant_Specs then Set_Has_Unknown_Discriminants (Derived_Type, False); @@ -6362,13 +6485,6 @@ package body Sem_Ch3 is 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 @@ -6613,6 +6729,29 @@ package body Sem_Ch3 is (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); end if; + -- Update the scope of anonymous access types of discriminants and other + -- components, to prevent scope anomalies in gigi, when the derivation + -- appears in a scope nested within that of the parent. + + declare + D : Entity_Id; + + begin + D := First_Entity (Derived_Type); + while Present (D) loop + if Ekind (D) = E_Discriminant + or else Ekind (D) = E_Component + then + if Is_Itype (Etype (D)) + and then Ekind (Etype (D)) = E_Anonymous_Access_Type + then + Set_Scope (Etype (D), Current_Scope); + end if; + end if; + + Next_Entity (D); + end loop; + end; end Build_Derived_Record_Type; ------------------------ @@ -7214,6 +7353,19 @@ package body Sem_Ch3 is elsif not For_Access then Set_Cloned_Subtype (Def_Id, T); end if; + + -- Handle subtypes associated with statically allocated dispatch + -- tables. + + if Static_Dispatch_Tables + and then VM_Target = No_VM + and then RTU_Loaded (Ada_Tags) + and then (T = RTE (RE_Dispatch_Table_Wrapper) + or else + T = RTE (RE_Type_Specific_Data)) + then + Set_Size_Known_At_Compile_Time (Def_Id); + end if; end if; end Build_Discriminated_Subtype; @@ -7458,9 +7610,10 @@ package body Sem_Ch3 is -- Local variables - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; -- Start of processing for Check_Abstract_Interfaces @@ -7476,16 +7629,19 @@ package body Sem_Ch3 is if Nkind (Type_Definition (N)) = N_Derived_Type_Definition and then Is_Interface (Etype (Defining_Identifier (N))) then + Parent_Node := Parent (Etype (Defining_Identifier (N))); + Check_Ifaces - (Iface_Def => Type_Definition - (Parent (Etype (Defining_Identifier (N)))), + (Iface_Def => Type_Definition (Parent_Node), 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)); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); if not Is_Interface (Iface_Typ) then Error_Msg_NE ("(Ada 2005) & must be an interface", @@ -7536,6 +7692,25 @@ package body Sem_Ch3 is -- operations used in dispatching selects since we always provide -- automatic overridings for these subprograms. + -- Also ignore this rule for convention CIL since .NET libraries + -- do bizarre things with interfaces??? + + -- The partial view of T may have been a private extension, for + -- which inherited functions dispatching on result are abstract. + -- If the full view is a null extension, there is no need for + -- overriding in Ada2005, but wrappers need to be built for them + -- (see exp_ch3, Build_Controlling_Function_Wrappers). + + if Is_Null_Extension (T) + and then Has_Controlling_Result (Subp) + and then Ada_Version >= Ada_05 + and then Present (Alias (Subp)) + and then not Comes_From_Source (Subp) + and then not Is_Abstract_Subprogram (Alias (Subp)) + then + goto Next_Subp; + end if; + if (Is_Abstract_Subprogram (Subp) or else Requires_Overriding (Subp) or else (Has_Controlling_Result (Subp) @@ -7545,6 +7720,7 @@ package body Sem_Ch3 is and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) + and then Convention (T) /= Convention_CIL 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 @@ -7663,7 +7839,8 @@ package body Sem_Ch3 is end if; end if; - Next_Elmt (Elmt); + <> + Next_Elmt (Elmt); end loop; end Check_Abstract_Overriding; @@ -8847,14 +9024,21 @@ package body Sem_Ch3 is Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); - -- Build a freeze node if parent still needs one. Also, make sure - -- that the Depends_On_Private status is set because the subtype - -- will need reprocessing at the time the base type does. - -- and also that a conditional delay is set. + -- A subtype does not inherit the packed_array_type of is parent. We + -- need to initialize the attribute because if Def_Id is previously + -- analyzed through a limited_with clause, it will have the attributes + -- of an incomplete type, one of which is an Elist that overlaps the + -- Packed_Array_Type field. + + Set_Packed_Array_Type (Def_Id, Empty); + + -- Build a freeze node if parent still needs one. Also make sure that + -- the Depends_On_Private status is set because the subtype will need + -- reprocessing at the time the base type does, and also we must set a + -- conditional delay. Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); Conditional_Delay (Def_Id, T); - end Constrain_Array; ------------------------------ @@ -10175,7 +10359,6 @@ package body Sem_Ch3 is if Ekind (Old_Compon) = E_Discriminant and then Is_Completely_Hidden (Old_Compon) then - -- This is a shadow discriminant created for a discriminant of -- the parent type that is one of several renamed by the same -- new discriminant. Give the shadow discriminant an internal @@ -10232,8 +10415,9 @@ package body Sem_Ch3 is return Nkind (Parent (T)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition and then Present (Component_List (Type_Definition (Parent (T)))) - and then Present ( - Variant_Part (Component_List (Type_Definition (Parent (T))))); + and then + Present + (Variant_Part (Component_List (Type_Definition (Parent (T))))); end Is_Variant_Record; -- Start of processing for Create_Constrained_Components @@ -10260,7 +10444,7 @@ package body Sem_Ch3 is Set_Has_Static_Discriminants (Subt, Is_Static); - New_Scope (Subt); + Push_Scope (Subt); -- Inherit the discriminants of the parent type @@ -10788,6 +10972,13 @@ package body Sem_Ch3 is Is_Abstract_Subprogram (E)); Remove_Homonym (Iface_Subp); + -- Hidden entities associated with interfaces must have set the + -- Has_Delay_Freeze attribute to ensure that the corresponding + -- entry of the secondary dispatch table is filled when such + -- entity is frozen. + + Set_Has_Delayed_Freeze (Iface_Subp); + Next_Elmt (Elmt); end loop; end if; @@ -11179,7 +11370,7 @@ package body Sem_Ch3 is then Set_Is_Abstract_Subprogram (New_Subp); - -- Finally, if the parent type is abstract we must verify that all + -- Finally, if the parent type is abstract we must verify that all -- inherited operations are either non-abstract or overridden, or -- that the derived type itself is abstract (this check is performed -- at the end of a package declaration, in Check_Abstract_Overriding). @@ -11193,8 +11384,18 @@ package body Sem_Ch3 is and then Is_Private_Overriding and then Is_Abstract_Subprogram (Visible_Subp) then - Set_Alias (New_Subp, Visible_Subp); - Set_Is_Abstract_Subprogram (New_Subp); + if No (Actual_Subp) then + Set_Alias (New_Subp, Visible_Subp); + Set_Is_Abstract_Subprogram + (New_Subp, True); + else + -- If this is a derivation for an instance of a formal derived + -- type, abstractness comes from the primitive operation of the + -- actual, not from the operation inherited from the ancestor. + + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); + end if; end if; New_Overloaded_Entity (New_Subp, Derived_Type); @@ -11296,17 +11497,58 @@ package body Sem_Ch3 is end if; else + + -- If the generic parent type is present, the derived type + -- is an instance of a formal derived type, and within the + -- instance its operations are those of the actual. We derive + -- from the formal type but make the inherited operations + -- aliases of the corresponding operations of the actual. + + if Is_Interface (Parent_Type) then + + -- Find the corresponding operation in the generic actual. + -- Given that the actual is not a direct descendant of the + -- parent, as in Ada 95, the primitives are not necessarily + -- in the same order, so we have to traverse the list of + -- primitive operations of the actual to find the one that + -- implements the interface operation. + + Act_Elmt := First_Elmt (Act_List); + + while Present (Act_Elmt) loop + exit when + Abstract_Interface_Alias (Node (Act_Elmt)) = Subp; + Next_Elmt (Act_Elmt); + end loop; + end if; + + -- If the formal is not an interface, the actual is a direct + -- descendant and the common primitive operations appear in + -- the same order. + Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); - Next_Elmt (Act_Elmt); + + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); + end if; end if; end if; Next_Elmt (Elmt); end loop; + -- Inherit additional operations from progenitor interfaces. + -- However, if the derived type is a generic actual, there + -- are not new primitive operations for the type, because + -- it has those of the actual, so nothing needs to be done. + -- The renamings generated above are not primitive operations, + -- and their purpose is simply to make the proper operations + -- visible within an instantiation. + if Ada_Version >= Ada_05 and then Is_Tagged_Type (Derived_Type) + and then No (Generic_Actual) then Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); end if; @@ -11397,13 +11639,7 @@ package body Sem_Ch3 is N : Node_Id; Is_Completion : Boolean) is - Def : constant Node_Id := Type_Definition (N); - Iface_Def : Node_Id; - Indic : constant Node_Id := Subtype_Indication (Def); - Extension : constant Node_Id := Record_Extension_Part (Def); Parent_Type : Entity_Id; - Parent_Scope : Entity_Id; - Taggd : Boolean; function Comes_From_Generic (Typ : Entity_Id) return Boolean; -- Check whether the parent type is a generic formal, or derives @@ -11435,6 +11671,16 @@ package body Sem_Ch3 is end if; end Comes_From_Generic; + -- Local variables + + Def : constant Node_Id := Type_Definition (N); + Iface_Def : Node_Id; + Indic : constant Node_Id := Subtype_Indication (Def); + Extension : constant Node_Id := Record_Extension_Part (Def); + Parent_Node : Node_Id; + Parent_Scope : Entity_Id; + Taggd : Boolean; + -- Start of processing for Derived_Type_Declaration begin @@ -11449,7 +11695,8 @@ package body Sem_Ch3 is Indic, Parent_Type); else - Iface_Def := Type_Definition (Parent (Parent_Type)); + Parent_Node := Parent (Base_Type (Parent_Type)); + Iface_Def := Type_Definition (Parent_Node); -- Ada 2005 (AI-251): Limited interfaces can only inherit from -- other limited interfaces. @@ -11535,7 +11782,12 @@ package body Sem_Ch3 is if not Is_Interface (T) then Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T); - elsif Limited_Present (Def) + -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow + -- a limited type from having a nonlimited progenitor. + + elsif (Limited_Present (Def) + or else (not Is_Interface (Parent_Type) + and then Is_Limited_Type (Parent_Type))) and then not Is_Limited_Interface (T) then Error_Msg_NE @@ -11906,9 +12158,14 @@ package body Sem_Ch3 is Set_Is_Static_Expression (B_Node, True); Set_High_Bound (R_Node, B_Node); - Set_Scalar_Range (T, R_Node); - Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); - Set_Enum_Esize (T); + + -- Initialize various fields of the type. Some of this information + -- may be overwritten later through rep.clauses. + + Set_Scalar_Range (T, R_Node); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Enum_Esize (T); + Set_Enum_Pos_To_Rep (T, Empty); -- Set Discard_Names if configuration pragma set, or if there is -- a parameterless pragma in the current declarative region @@ -12290,10 +12547,7 @@ package body Sem_Ch3 is elsif Def_Kind = N_Access_Definition then T := Access_Definition (Related_Nod, Obj_Def); - - if Nkind (Parent (Related_Nod)) /= N_Extended_Return_Statement then - Set_Is_Local_Anonymous_Access (T); - end if; + Set_Is_Local_Anonymous_Access (T); -- Otherwise, the object definition is just a subtype_mark @@ -12848,35 +13102,10 @@ package body Sem_Ch3 is -- type T_2 is new Pack_1.T_1 with ...; -- end Pack_2; - -- When Comp is being duplicated for type T_2, its designated - -- type must be set to point to the non-limited view of T_2. - - if Ada_Version >= Ada_05 - and then - Ekind (Etype (New_C)) = E_Anonymous_Access_Type - and then - Ekind (Directly_Designated_Type - (Etype (New_C))) = E_Incomplete_Type - and then - From_With_Type (Directly_Designated_Type (Etype (New_C))) - and then - Present (Non_Limited_View - (Directly_Designated_Type (Etype (New_C)))) - and then - Non_Limited_View (Directly_Designated_Type - (Etype (New_C))) = Derived_Base - then - Set_Directly_Designated_Type - (Etype (New_C), - Non_Limited_View - (Directly_Designated_Type (Etype (New_C)))); - - else - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Derived_Base, N, Parent_Base, Discs)); - end if; + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Derived_Base, N, Parent_Base, Discs)); end if; end if; @@ -12886,7 +13115,13 @@ package body Sem_Ch3 is -- Record_Type_Definition after processing the record extension of -- the derived type. - if Is_Tagged and then Ekind (New_C) = E_Component then + -- If the declaration is a private extension, there is no further + -- record extension to process, and the components retain their + -- current kind, because they are visible at this point. + + if Is_Tagged and then Ekind (New_C) = E_Component + and then Nkind (N) /= N_Private_Extension_Declaration + then Set_Ekind (New_C, E_Void); end if; @@ -13006,13 +13241,11 @@ package body Sem_Ch3 is Component := First_Entity (Parent_Base); while Present (Component) loop - -- Ada 2005 (AI-251): Do not inherit tags corresponding with the - -- interfaces of the parent + -- Ada 2005 (AI-251): Do not inherit components associated with + -- secondary tags of the parent. if Ekind (Component) = E_Component - and then Is_Tag (Component) - and then RTE_Available (RE_Interface_Tag) - and then Etype (Component) = RTE (RE_Interface_Tag) + and then Present (Related_Interface (Component)) then null; @@ -13064,9 +13297,9 @@ package body Sem_Ch3 is ----------------------- function Is_Null_Extension (T : Entity_Id) return Boolean is - Type_Decl : constant Node_Id := Parent (T); - Comp_List : Node_Id; - First_Comp : Node_Id; + Type_Decl : constant Node_Id := Parent (T); + Comp_List : Node_Id; + Comp : Node_Id; begin if Nkind (Type_Decl) /= N_Full_Type_Declaration @@ -13087,11 +13320,22 @@ package body Sem_Ch3 is elsif Present (Comp_List) and then Is_Non_Empty_List (Component_Items (Comp_List)) then - First_Comp := First (Component_Items (Comp_List)); + Comp := First (Component_Items (Comp_List)); + + -- Only user-defined components are relevant. The component list + -- may also contain a parent component and internal components + -- corresponding to secondary tags, but these do not determine + -- whether this is a null extension. + + while Present (Comp) loop + if Comes_From_Source (Comp) then + return False; + end if; - return Chars (Defining_Identifier (First_Comp)) = Name_uParent - and then No (Next (First_Comp)); + Next (Comp); + end loop; + return True; else return True; end if; @@ -13405,19 +13649,13 @@ package body Sem_Ch3 is if not Is_Overloaded (I) then T := Etype (I); - -- If the bounds are universal, choose the specific predefined - -- type. + -- For universal bounds, choose the specific predefined type if T = Universal_Integer then T := Standard_Integer; elsif T = Any_Character then - - if Ada_Version >= Ada_95 then - Error_Msg_N - ("ambiguous character literals (could be Wide_Character)", - I); - end if; + Ambiguous_Character (Low_Bound (I)); T := Standard_Character; end if; @@ -13742,7 +13980,7 @@ package body Sem_Ch3 is if Bits > System_Max_Nonbinary_Modulus_Power then Error_Msg_Uint_1 := UI_From_Int (System_Max_Nonbinary_Modulus_Power); - Error_Msg_N + Error_Msg_F ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); Set_Modular_Size (System_Max_Binary_Modulus_Power); return; @@ -13761,11 +13999,10 @@ package body Sem_Ch3 is -- so we just signal an error and set the maximum size. Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); - Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr); + Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); Set_Modular_Size (System_Max_Binary_Modulus_Power); Init_Alignment (T); - end Modular_Type_Declaration; -------------------------- @@ -13844,16 +14081,25 @@ package body Sem_Ch3 is -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front-end in -- case of limited aggregates (including extension aggregates), - -- and function calls. + -- and function calls. The function call may have been give in prefixed + -- notation, in which case the original node is an indexed component. case Nkind (Original_Node (Exp)) is - when N_Aggregate | N_Extension_Aggregate | N_Function_Call => + when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => return True; - when N_Qualified_Expression => + -- Ada 2005 (AI-251): If a class-wide interface object is initialized + -- with a function call, the expander has rewriten the call into an + -- N_Type_Conversion node to force displacement of the pointer to + -- reference the component containing the secondary dispatch table. + + when N_Qualified_Expression | N_Type_Conversion => return OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp))); + when N_Indexed_Component => + return Nkind (Exp) = N_Function_Call; + when others => return False; end case; @@ -14071,18 +14317,6 @@ package body Sem_Ch3 is if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); - -- Ada 2005 (AI-230): Access discriminants are now allowed for - -- nonlimited types, and are treated like other components of - -- anonymous access types in terms of accessibility. - - if not Is_Concurrent_Type (Current_Scope) - and then not Is_Concurrent_Record_Type (Current_Scope) - and then not Is_Limited_Record (Current_Scope) - and then Ekind (Current_Scope) /= E_Limited_Private_Type - then - Set_Is_Local_Anonymous_Access (Discr_Type); - end if; - -- Ada 2005 (AI-254) if Present (Access_To_Subprogram_Definition @@ -14186,9 +14420,10 @@ package body Sem_Ch3 is and then not Is_Itype (Discr_Type) then if Can_Never_Be_Null (Discr_Type) then - Error_Msg_N - ("null-exclusion cannot be applied to " & - "a null excluding type", Discr); + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Discr, + Discr_Type); end if; Set_Etype (Defining_Identifier (Discr), @@ -14755,8 +14990,8 @@ package body Sem_Ch3 is end loop; end; - -- If the private view was tagged, copy the new Primitive - -- operations from the private view to the full view. + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. if Is_Tagged_Type (Full_T) and then not Is_Concurrent_Type (Full_T) @@ -14876,6 +15111,14 @@ package body Sem_Ch3 is Set_Must_Have_Preelab_Init (Full_T); end if; end if; + + -- If pragma CPP_Class was applied to the private type declaration, + -- propagate it now to the full type declaration. + + if Is_CPP_Class (Priv_T) then + Set_Is_CPP_Class (Full_T); + Set_Convention (Full_T, Convention_CPP); + end if; end Process_Full_View; ----------------------------------- @@ -15308,8 +15551,7 @@ package body Sem_Ch3 is and then Nkind (P) /= N_Access_To_Object_Definition and then not Is_Access_Type (Entity (S)) then - Error_Msg_N - ("null-exclusion must be applied to an access type", S); + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); end if; May_Have_Null_Exclusion := @@ -15371,9 +15613,10 @@ package body Sem_Ch3 is Error_Node := Related_Nod; end case; - Error_Msg_N - ("null-exclusion cannot be applied to " & - "a null excluding type", Error_Node); + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); end if; Set_Etype (S, @@ -15680,6 +15923,37 @@ package body Sem_Ch3 is Subt : Node_Id; Type_Id : constant Name_Id := Chars (Typ); + function Names_T (Nam : Node_Id) return Boolean; + + -- The record type has not been introduced in the current scope + -- yet, so we must examine the name of the type itself, either + -- an identifier T, or an expanded name of the form P.T, where + -- P denotes the current scope. + + function Names_T (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Identifier then + return Chars (Nam) = Type_Id; + + elsif Nkind (Nam) = N_Selected_Component then + if Chars (Selector_Name (Nam)) = Type_Id then + if Nkind (Prefix (Nam)) = N_Identifier then + return Chars (Prefix (Nam)) = Chars (Current_Scope); + + elsif Nkind (Prefix (Nam)) = N_Selected_Component then + return Chars (Selector_Name (Prefix (Nam))) + = Chars (Current_Scope); + else + return False; + end if; + else + return False; + end if; + else + return False; + end if; + end Names_T; + begin if No (Access_To_Subprogram_Definition (Acc_Def)) then Subt := Subtype_Mark (Acc_Def); @@ -15688,15 +15962,13 @@ package body Sem_Ch3 is return Chars (Subt) = Type_Id; -- Reference can be through an expanded name which has not been - -- analyzed yet, and designates enclosing scopes. + -- analyzed yet, and which designates enclosing scopes. elsif Nkind (Subt) = N_Selected_Component then - Analyze (Prefix (Subt)); - - if Chars (Selector_Name (Subt)) = Type_Id then - return Is_Entity_Name (Prefix (Subt)) - and then Entity (Prefix (Subt)) = Current_Scope; + if Names_T (Subt) then + return True; + -- Otherwise it must denote an entity that is already visible. -- The access definition may name a subtype of the enclosing -- type, if there is a previous incomplete declaration for it. @@ -15717,10 +15989,9 @@ package body Sem_Ch3 is -- a 'Class attribute. elsif Nkind (Subt) = N_Attribute_Reference - and then Attribute_Name (Subt) = Name_Class - and then Is_Entity_Name (Prefix (Subt)) + and then Attribute_Name (Subt) = Name_Class then - return (Chars (Prefix (Subt))) = Type_Id; + return Names_T (Prefix (Subt)); else return False; end if; @@ -15801,11 +16072,21 @@ package body Sem_Ch3 is Relocate_Node (Subtype_Mark (Access_Definition (Comp_Def)))); + + Set_Constant_Present + (Type_Def, Constant_Present (Access_Definition (Comp_Def))); + Set_All_Present + (Type_Def, All_Present (Access_Definition (Comp_Def))); end if; - Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + Set_Null_Exclusion_Present + (Type_Def, + Null_Exclusion_Present (Access_Definition (Comp_Def))); + + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); Insert_Before (Typ_Decl, Decl); Analyze (Decl); @@ -15951,7 +16232,7 @@ package body Sem_Ch3 is -- Enter record scope - New_Scope (T); + Push_Scope (T); -- If an incomplete or private type declaration was already given for -- the type, then this scope already exists, and the discriminants have @@ -16082,11 +16363,14 @@ package body Sem_Ch3 is -- After completing the semantic analysis of the record definition, -- record components, both new and inherited, are accessible. Set their - -- kind accordingly. + -- kind accordingly. Exclude malformed itypes from illegal declarations, + -- whose Ekind may be void. Component := First_Entity (Current_Scope); while Present (Component) loop - if Ekind (Component) = E_Void then + if Ekind (Component) = E_Void + and then not Is_Itype (Component) + then Set_Ekind (Component, E_Component); Init_Component_Location (Component); end if; -- 2.30.2