diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 645 |
1 files changed, 455 insertions, 190 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d2442b4..7d706ce 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -658,10 +658,10 @@ package body Sem_Ch3 is (Def_Id : Entity_Id; R : Node_Id; Subt : Entity_Id); - -- This routine is used to set the scalar range field for a subtype - -- given Def_Id, the entity for the subtype, and R, the range expression - -- for the scalar range. Subt provides the parent subtype to be used - -- to analyze, resolve, and check the given range. + -- This routine is used to set the scalar range field for a subtype given + -- Def_Id, the entity for the subtype, and R, the range expression for the + -- scalar range. Subt provides the parent subtype to be used to analyze, + -- resolve, and check the given range. procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Create a new signed integer entity, and apply the constraint to obtain @@ -680,9 +680,7 @@ package body Sem_Ch3 is (Related_Nod : Node_Id; N : Node_Id) return Entity_Id is - Anon_Type : constant Entity_Id := - Create_Itype (E_Anonymous_Access_Type, Related_Nod, - Scope_Id => Scope (Current_Scope)); + Anon_Type : Entity_Id; Desig_Type : Entity_Id; begin @@ -692,16 +690,14 @@ package body Sem_Ch3 is Error_Msg_N ("task entries cannot have access parameters", N); end if; - -- Ada 2005: for an object declaration or function with an anonymous - -- access result, the corresponding anonymous type is declared in the - -- current scope. For access formals, access components, and access - -- discriminants, the scope is that of the enclosing declaration, - -- as set above. This special-case handling of resetting the scope - -- is awkward, and it might be better to pass in the required scope - -- as a parameter. ??? + -- Ada 2005: for an object declaration the corresponding anonymous + -- type is declared in the current scope. if Nkind (Related_Nod) = N_Object_Declaration then - Set_Scope (Anon_Type, Current_Scope); + Anon_Type := + Create_Itype + (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 @@ -713,7 +709,19 @@ package body Sem_Ch3 is elsif Nkind (Related_Nod) = N_Function_Specification and then Nkind (Parent (N)) /= N_Parameter_Specification then - Set_Scope (Anon_Type, Scope (Defining_Unit_Name (Related_Nod))); + Anon_Type := + Create_Itype + (E_Anonymous_Access_Type, Related_Nod, + Scope_Id => Scope (Defining_Unit_Name (Related_Nod))); + + 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)); end if; if All_Present (N) @@ -1081,9 +1089,10 @@ package body Sem_Ch3 is ------------- procedure Add_Tag (Iface : Entity_Id) is - Def : Node_Id; - Tag : Entity_Id; - Decl : Node_Id; + Decl : Node_Id; + Def : Node_Id; + Tag : Entity_Id; + Offset : Entity_Id; begin pragma Assert (Is_Tagged_Type (Iface) @@ -1115,21 +1124,52 @@ package body Sem_Ch3 is Set_DT_Entry_Count (Tag, DT_Entry_Count (First_Entity (Iface))); - if not Present (Last_Tag) then + if No (Last_Tag) then Prepend (Decl, L); else Insert_After (Last_Tag, Decl); end if; Last_Tag := Decl; + + -- If the ancestor has discriminants we need to give special support + -- to store the offset_to_top value of the secondary dispatch tables. + -- For this purpose we add a supplementary component just after the + -- field that contains the tag associated with each secondary DT. + + if Typ /= Etype (Typ) + and then Has_Discriminants (Etype (Typ)) + then + Def := + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); + + Offset := + Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + + Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Offset, + Component_Definition => Def); + + Analyze_Component_Declaration (Decl); + + Set_Analyzed (Decl); + Set_Ekind (Offset, E_Component); + Init_Component_Location (Offset); + Insert_After (Last_Tag, Decl); + Last_Tag := Decl; + end if; end Add_Tag; -- Start of processing for Add_Interface_Tag_Components begin if Ekind (Typ) /= E_Record_Type - or else not Present (Abstract_Interfaces (Typ)) + or else No (Abstract_Interfaces (Typ)) or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + or else not RTE_Available (RE_Interface_Tag) then return; end if; @@ -1207,6 +1247,13 @@ package body Sem_Ch3 is -- Determines whether a constraint uses the discriminant of a record -- type thus becoming a per-object constraint (POC). + function Is_Known_Limited (Typ : Entity_Id) return Boolean; + -- Check whether enclosing record is limited, to validate declaration + -- of components with limited types. + -- This seems a wrong description to me??? + -- What is Typ? For sure it can return a result without checking + -- the enclosing record (enclosing what???) + ------------------ -- Contains_POC -- ------------------ @@ -1259,6 +1306,41 @@ package body Sem_Ch3 is end case; end Contains_POC; + ---------------------- + -- Is_Known_Limited -- + ---------------------- + + function Is_Known_Limited (Typ : Entity_Id) return Boolean is + P : constant Entity_Id := Etype (Typ); + R : constant Entity_Id := Root_Type (Typ); + + begin + if Is_Limited_Record (Typ) then + return True; + + -- If the root type is limited (and not a limited interface) + -- so is the current type + + elsif Is_Limited_Record (R) + and then + (not Is_Interface (R) + or else not Is_Limited_Interface (R)) + then + return True; + + -- Else the type may have a limited interface progenitor, but a + -- limited record parent. + + elsif R /= P + and then Is_Limited_Record (P) + then + return True; + + else + return False; + end if; + end Is_Known_Limited; + -- Start of processing for Analyze_Component_Declaration begin @@ -1321,6 +1403,40 @@ package body Sem_Ch3 is if Present (Expression (N)) then Analyze_Per_Use_Expression (Expression (N), T); Check_Initialization (T, Expression (N)); + + 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 + -- an anonymous access-to-specific tagged type, then the object + -- designated by the expression shall not be dynamically tagged + -- unless it is a controlling operand in a call on a dispatching + -- operation" + + if Is_Tagged_Type (Directly_Designated_Type (T)) + and then + Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type + and then + Ekind (Directly_Designated_Type (Etype (Expression (N)))) = + E_Class_Wide_Type + then + Error_Msg_N + ("access to specific tagged type required ('R'M 3.9.2(9))", + Expression (N)); + end if; + + -- (Ada 2005: AI-230): Accessibility check for anonymous + -- components + + if Type_Access_Level (Etype (Expression (N))) > + Type_Access_Level (T) + then + Error_Msg_N + ("expression has deeper access level than component " & + "('R'M 3.10.2 (12.2))", Expression (N)); + end if; + end if; end if; -- The parent type may be a private view with unknown discriminants, @@ -1406,11 +1522,19 @@ package body Sem_Ch3 is and then Is_Tagged_Type (Current_Scope) then if Is_Derived_Type (Current_Scope) - and then not Is_Limited_Record (Root_Type (Current_Scope)) + and then not Is_Known_Limited (Current_Scope) then Error_Msg_N ("extension of nonlimited type cannot have limited components", N); + + if Is_Interface (Root_Type (Current_Scope)) then + Error_Msg_N + ("\limitedness is not inherited from limited interface", N); + Error_Msg_N + ("\add LIMITED to type indication", N); + end if; + Explain_Limited_Type (T, N); Set_Etype (Id, Any_Type); Set_Is_Limited_Composite (Current_Scope, False); @@ -2067,7 +2191,7 @@ package body Sem_Ch3 is -- In case of errors detected in the analysis of the expression, -- decorate it with the expected type to avoid cascade errors - if not Present (Etype (E)) then + if No (Etype (E)) then Set_Etype (E, T); end if; @@ -2660,7 +2784,11 @@ package body Sem_Ch3 is if Limited_Present (N) then Set_Is_Limited_Record (T); - if not Is_Limited_Type (Parent_Type) then + if not Is_Limited_Type (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) + then Error_Msg_NE ("parent type& of limited extension must be limited", N, Parent_Type); end if; @@ -5332,7 +5460,6 @@ package body Sem_Ch3 is Constraint_Present : Boolean; Has_Interfaces : Boolean := False; Inherit_Discrims : Boolean := False; - Last_Inherited_Prim_Op : Elmt_Id; Tagged_Partial_View : Entity_Id; Save_Etype : Entity_Id; Save_Discr_Constr : Elist_Id; @@ -5768,7 +5895,7 @@ package body Sem_Ch3 is Discrim := First_Discriminant (Derived_Type); while Present (Discrim) loop if not Is_Tagged - and then not Present (Corresponding_Discriminant (Discrim)) + and then No (Corresponding_Discriminant (Discrim)) then Error_Msg_N ("new discriminants must constrain old ones", Discrim); @@ -6006,40 +6133,6 @@ package body Sem_Ch3 is else Collect_Interfaces (Type_Definition (N), Derived_Type); end if; - - -- Ada 2005 (AI-251): The progenitor types specified in a private - -- extension declaration and the progenitor types specified in the - -- corresponding declaration of a record extension given in the - -- private part need not be the same; the only requirement is that - -- the private extension must be descended from each interface - -- from which the record extension is descended (AARM 7.3, 20.1/2) - - if Has_Private_Declaration (Derived_Type) then - declare - N_Partial : constant Node_Id := Parent (Tagged_Partial_View); - Iface_Partial : Entity_Id; - - begin - if Nkind (N_Partial) = N_Private_Extension_Declaration - and then not Is_Empty_List (Interface_List (N_Partial)) - then - Iface_Partial := First (Interface_List (N_Partial)); - - while Present (Iface_Partial) loop - if not Interface_Present_In_Ancestor - (Derived_Type, Etype (Iface_Partial)) - then - Error_Msg_N - ("(Ada 2005) full type and private extension must" - & " have the same progenitors", Derived_Type); - exit; - end if; - - Next (Iface_Partial); - end loop; - end if; - end; - end if; end if; else @@ -6060,8 +6153,9 @@ package body Sem_Ch3 is Constrs := Discriminant_Constraint (Parent_Type); end if; - Assoc_List := Inherit_Components (N, - Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); + Assoc_List := + Inherit_Components + (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); -- STEP 5a: Copy the parent record declaration for untagged types @@ -6208,116 +6302,103 @@ package body Sem_Ch3 is end; end if; - -- Ada 2005 (AI-251): Keep separate the management of tagged types - -- implementing interfaces + Derive_Subprograms (Parent_Type, Derived_Type); + + -- Ada 2005 (AI-251): Handle tagged types implementing interfaces - if not Is_Tagged_Type (Derived_Type) - or else not Has_Interfaces + if Is_Tagged_Type (Derived_Type) + and then Has_Interfaces then - Derive_Subprograms (Parent_Type, Derived_Type); + -- Ada 2005 (AI-251): If we are analyzing a full view that has + -- no partial view we derive the abstract interface Subprograms - else - -- Ada 2005 (AI-251): Complete the decoration of tagged private - -- types that implement interfaces + if No (Tagged_Partial_View) then + Derive_Interface_Subprograms (Derived_Type); - if Present (Tagged_Partial_View) then - Derive_Subprograms - (Parent_Type, Derived_Type); + -- Ada 2005 (AI-251): if we are analyzing a full view that has + -- a partial view we complete the derivation of the subprograms + else Complete_Subprograms_Derivation (Partial_View => Tagged_Partial_View, Derived_Type => Derived_Type); + end if; - -- Ada 2005 (AI-251): Derive the interface subprograms of all the - -- implemented interfaces and check if some of the subprograms - -- inherited from the ancestor cover some interface subprogram. + -- Ada 2005 (AI-251): In both cases we check if some of the + -- inherited subprograms cover interface primitives. - else - Derive_Subprograms (Parent_Type, Derived_Type); + declare + Iface_Subp : Entity_Id; + Iface_Subp_Elmt : Elmt_Id; + Prev_Alias : Entity_Id; + Subp : Entity_Id; + Subp_Elmt : Elmt_Id; - declare - Subp_Elmt : Elmt_Id; - First_Iface_Elmt : Elmt_Id; - Iface_Subp_Elmt : Elmt_Id; - Subp : Entity_Id; - Iface_Subp : Entity_Id; - Is_Interface_Subp : Boolean; + begin + Iface_Subp_Elmt := + First_Elmt (Primitive_Operations (Derived_Type)); + while Present (Iface_Subp_Elmt) loop + Iface_Subp := Node (Iface_Subp_Elmt); + + -- Look for an abstract interface subprogram + + if Is_Abstract (Iface_Subp) + and then Present (Alias (Iface_Subp)) + and then Present (DTC_Entity (Alias (Iface_Subp))) + and then Is_Interface + (Scope (DTC_Entity (Alias (Iface_Subp)))) + then + -- Look for candidate primitive subprograms of the tagged + -- type that can cover this interface subprogram. - begin - -- Ada 2005 (AI-251): Remember the entity corresponding to - -- the last inherited primitive operation. This is required - -- to check if some of the inherited subprograms covers some - -- of the new interfaces. - - Last_Inherited_Prim_Op := No_Elmt; - - Subp_Elmt := - First_Elmt (Primitive_Operations (Derived_Type)); - while Present (Subp_Elmt) loop - Last_Inherited_Prim_Op := Subp_Elmt; - Next_Elmt (Subp_Elmt); - end loop; + Subp_Elmt := + First_Elmt (Primitive_Operations (Derived_Type)); + while Present (Subp_Elmt) loop + Subp := Node (Subp_Elmt); - -- Ada 2005 (AI-251): Derive subprograms in abstract - -- interfaces. + if not Is_Abstract (Subp) + and then Chars (Subp) = Chars (Iface_Subp) + and then Type_Conformant (Iface_Subp, Subp) + then + Prev_Alias := Alias (Iface_Subp); - Derive_Interface_Subprograms (Derived_Type); - - -- Ada 2005 (AI-251): Check if some of the inherited - -- subprograms cover some of the new interfaces. - - if Present (Last_Inherited_Prim_Op) then - First_Iface_Elmt := Next_Elmt (Last_Inherited_Prim_Op); - Iface_Subp_Elmt := First_Iface_Elmt; - while Present (Iface_Subp_Elmt) loop - Subp_Elmt := First_Elmt (Primitive_Operations - (Derived_Type)); - while Subp_Elmt /= First_Iface_Elmt loop - Subp := Node (Subp_Elmt); - Iface_Subp := Node (Iface_Subp_Elmt); - - Is_Interface_Subp := - Present (Alias (Subp)) - and then Present (DTC_Entity (Alias (Subp))) - and then Is_Interface (Scope - (DTC_Entity - (Alias (Subp)))); - - if Chars (Subp) = Chars (Iface_Subp) - and then not Is_Interface_Subp - and then not Is_Abstract (Subp) - and then Type_Conformant (Iface_Subp, Subp) - then - Check_Dispatching_Operation - (Subp => Subp, - Old_Subp => Iface_Subp); - - -- Traverse the list of aliased subprograms - - declare - E : Entity_Id; - - begin - E := Alias (Subp); - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - Set_Alias (Subp, E); - end; - - Set_Has_Delayed_Freeze (Subp); - exit; - end if; - - Next_Elmt (Subp_Elmt); - end loop; + Check_Dispatching_Operation + (Subp => Subp, + Old_Subp => Iface_Subp); + + pragma Assert + (Alias (Iface_Subp) = Subp); + pragma Assert + (Abstract_Interface_Alias (Iface_Subp) + = Prev_Alias); + + -- Traverse the list of aliased subprograms to link + -- subp with its ultimate aliased subprogram. This + -- avoids problems with the backend. + + declare + E : Entity_Id; + + begin + E := Alias (Subp); + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + Set_Alias (Subp, E); + end; - Next_Elmt (Iface_Subp_Elmt); + Set_Has_Delayed_Freeze (Subp); + exit; + end if; + + Next_Elmt (Subp_Elmt); end loop; end if; - end; - end if; + + Next_Elmt (Iface_Subp_Elmt); + end loop; + end; end if; end if; @@ -7092,10 +7173,11 @@ package body Sem_Ch3 is ------------------------------- procedure Check_Abstract_Overriding (T : Entity_Id) is - Op_List : Elist_Id; - Elmt : Elmt_Id; - Subp : Entity_Id; - Type_Def : Node_Id; + Op_List : Elist_Id; + Elmt : Elmt_Id; + Subp : Entity_Id; + Alias_Subp : Entity_Id; + Type_Def : Node_Id; begin Op_List := Primitive_Operations (T); @@ -7105,13 +7187,22 @@ package body Sem_Ch3 is Elmt := First_Elmt (Op_List); while Present (Elmt) loop Subp := Node (Elmt); + Alias_Subp := Alias (Subp); + + -- Inherited subprograms are identified by the fact that they do not + -- come from source, and the associated source location is the + -- location of the first subtype of the derived type. -- 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) + 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)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract (T) @@ -7120,31 +7211,44 @@ package body Sem_Ch3 is and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind and then Chars (Subp) /= Name_uDisp_Timed_Select then - if Present (Alias (Subp)) then - - -- Only perform the check for a derived subprogram when - -- the type has an explicit record extension. This avoids - -- incorrectly flagging abstract subprograms for the case - -- of a type without an extension derived from a formal type - -- with a tagged actual (can occur within a private part). + if Present (Alias_Subp) then + + -- Only perform the check for a derived subprogram when the + -- type has an explicit record extension. This avoids + -- incorrectly flagging abstract subprograms for the case of a + -- type without an extension derived from a formal type with a + -- tagged actual (can occur within a private part). + + -- Ada 2005 (AI-391): In the case of an inherited function with + -- a controlling result of the type, the rule does not apply if + -- the type is a null extension (unless the parent function + -- itself is abstract, in which case the function must still be + -- be overridden). The expander will generate an overriding + -- wrapper function calling the parent subprogram (see + -- Exp_Ch3.Make_Controlling_Wrapper_Functions). Type_Def := Type_Definition (Parent (T)); if Nkind (Type_Def) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Type_Def)) + and then + (Ada_Version < Ada_05 + 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_Access_Type (Etype (Subp))) then Error_Msg_NE ("type must be declared abstract or & overridden", T, Subp); -- Traverse the whole chain of aliased subprograms to - -- complete the error notification. This is useful for - -- traceability of the chain of entities when the subprogram - -- corresponds with interface subprogram (that may be - -- defined in another package) + -- complete the error notification. This is especially + -- useful for traceability of the chain of entities when the + -- subprogram corresponds with an interface subprogram + -- (which might be defined in another package) - if Ada_Version >= Ada_05 - and then Present (Alias (Subp)) - then + if Present (Alias_Subp) then declare E : Entity_Id; @@ -7657,7 +7761,7 @@ package body Sem_Ch3 is Next_Elmt (Elmt); end loop; - if not Present (Elmt) then + if No (Elmt) then Append_Elmt (Node => Iface, To => Abstract_Interfaces (Derived_Type)); end if; @@ -8018,6 +8122,15 @@ package body Sem_Ch3 is Obj_Def : constant Node_Id := Object_Definition (N); New_T : Entity_Id; + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id); + -- Determine whether the two object definitions describe the partial + -- and the full view of a constrained deferred constant. Generate + -- a subtype for the full view and verify that it statically matches + -- the subtype of the partial view. + procedure Check_Recursive_Declaration (Typ : Entity_Id); -- If deferred constant is an access type initialized with an allocator, -- check whether there is an illegal recursion in the definition, @@ -8025,6 +8138,46 @@ package body Sem_Ch3 is -- detected when generating init procs, but requires this additional -- mechanism when expansion is disabled. + ---------------------------------------- + -- Check_Possible_Deferred_Completion -- + ---------------------------------------- + + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id) + is + begin + if Nkind (Prev_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Prev_Obj_Def)) + and then Nkind (Curr_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Curr_Obj_Def)) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); + Decl : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Def_Id, + Subtype_Indication => + Relocate_Node (Curr_Obj_Def)); + + begin + Insert_Before_And_Analyze (N, Decl); + Set_Etype (Id, Def_Id); + + if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then + Error_Msg_Sloc := Sloc (Prev_Id); + Error_Msg_N ("subtype does not statically match deferred " & + "declaration#", N); + end if; + end; + end if; + end Check_Possible_Deferred_Completion; + --------------------------------- -- Check_Recursive_Declaration -- --------------------------------- @@ -8124,6 +8277,16 @@ package body Sem_Ch3 is -- If so, process the full constant declaration else + -- RM 7.4 (6): If the subtype defined by the subtype_indication in + -- the deferred declaration is constrained, then the subtype defined + -- by the subtype_indication in the full declaration shall match it + -- statically. + + Check_Possible_Deferred_Completion + (Prev_Id => Prev, + Prev_Obj_Def => Object_Definition (Parent (Prev)), + Curr_Obj_Def => Obj_Def); + Set_Full_View (Prev, Id); Set_Is_Public (Id, Is_Public (Prev)); Set_Is_Internal (Id); @@ -10413,6 +10576,13 @@ package body Sem_Ch3 is (New_Subp, Is_Valued_Procedure (Parent_Subp)); end if; + -- No_Return must be inherited properly. If this is overridden in the + -- case of a dispatching operation, then a check is made in Sem_Disp + -- that the overriding operation is also No_Return (no such check is + -- required for the case of non-dispatching operation. + + Set_No_Return (New_Subp, No_Return (Parent_Subp)); + -- A derived function with a controlling result is abstract. If the -- Derived_Type is a nonabstract formal generic derived type, then -- inherited operations are not abstract: the required check is done at @@ -10845,7 +11015,7 @@ package body Sem_Ch3 is Partial_View := First_Entity (Current_Scope); loop - exit when not Present (Partial_View) + exit when No (Partial_View) or else (Has_Private_Declaration (Partial_View) and then Full_View (Partial_View) = T); @@ -11020,13 +11190,15 @@ package body Sem_Ch3 is Build_Derived_Type (N, Parent_Type, T, Is_Completion); -- AI-419: the parent type of an explicitly limited derived type must - -- be limited. Interface progenitors were checked earlier. + -- be a limited type or a limited interface. if Limited_Present (Def) then Set_Is_Limited_Record (T); if not Is_Limited_Type (Parent_Type) - and then not Is_Interface (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) then Error_Msg_NE ("parent type& of limited type must be limited", N, Parent_Type); @@ -11273,6 +11445,21 @@ package body Sem_Ch3 is then Error_Msg_N ("completion of nonlimited type cannot be limited", N); + + elsif Ekind (Prev) = E_Record_Type_With_Private + and then + (Nkind (N) = N_Task_Type_Declaration + or else Nkind (N) = N_Protected_Type_Declaration) + then + if not Is_Limited_Record (Prev) then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); + + elsif No (Interface_List (N)) then + Error_Msg_N + ("completion of tagged private type must be tagged", + N); + end if; end if; -- Ada 2005 (AI-251): Private extension declaration of a @@ -12144,6 +12331,7 @@ package body Sem_Ch3 is 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) then null; @@ -12191,6 +12379,41 @@ package body Sem_Ch3 is return Assoc_List; end Inherit_Components; + ----------------------- + -- Is_Null_Extension -- + ----------------------- + + 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; + + begin + if not Is_Tagged_Type (T) + or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition + then + return False; + end if; + + Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn)); + + if Present (Discriminant_Specifications (Full_Type_Decl)) then + return False; + + elsif Present (Comp_List) + and then Is_Non_Empty_List (Component_Items (Comp_List)) + then + First_Comp := First (Component_Items (Comp_List)); + + return Chars (Defining_Identifier (First_Comp)) = Name_uParent + and then No (Next (First_Comp)); + + else + return True; + end if; + end Is_Null_Extension; + ------------------------------ -- Is_Valid_Constraint_Kind -- ------------------------------ @@ -13111,7 +13334,7 @@ package body Sem_Ch3 is end if; if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then - Discr_Type := Access_Definition (N, Discriminant_Type (Discr)); + 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 @@ -13344,6 +13567,14 @@ package body Sem_Ch3 is Iface_Elmt : Elmt_Id; begin + -- Abstract interfaces are only associated with tagged record types + + if not Is_Tagged_Type (Typ) + or else not Is_Record_Type (Typ) + then + return; + end if; + -- Implementations of the form: -- type Typ is new Iface ... @@ -13361,10 +13592,11 @@ package body Sem_Ch3 is while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); - if Is_Interface (Iface) - and then not Contain_Interface (Iface, Ifaces) - then + pragma Assert (Is_Interface (Iface)); + + if not Contain_Interface (Iface, Ifaces) then Append_Elmt (Iface, Ifaces); + Collect_Implemented_Interfaces (Iface, Ifaces); end if; Next_Elmt (Iface_Elmt); @@ -13495,15 +13727,22 @@ package body Sem_Ch3 is Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); - -- Ada 2005 (AI-396): The partial view shall be a descendant of - -- an interface type if and only if the full view is a descendant - -- of the interface type. + -- Ada 2005 (AI-251): The partial view shall be a descendant of + -- an interface type if and only if the full type is descendant + -- of the interface type (AARM 7.3 (7.3/2). + + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE ("interface & not implemented by full type " & + "('R'M'-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then Error_Msg_NE ("interface & not implemented by partial view " & - "('R'M'-2005 7.3(9))", Full_T, Iface); + "('R'M'-2005 7.3 (7.3/2))", Full_T, Iface); end if; end; end if; @@ -13543,7 +13782,14 @@ package body Sem_Ch3 is then null; - elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then + -- Ada 2005 (AI-251): If the parent of the private type declaration + -- is an interface there is no need to check that it is an ancestor + -- of the associated full type declaration. The required tests for + -- this case case are performed by Build_Derived_Record_Type. + + elsif not Is_Interface (Base_Type (Priv_Parent)) + and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) + then Error_Msg_N ("parent of full type must descend from parent" & " of private extension", Full_Indic); @@ -13554,7 +13800,7 @@ package body Sem_Ch3 is -- subtype of the full type must be constrained if and only if -- the ancestor subtype of the private extension is constrained. - elsif not Present (Discriminant_Specifications (Parent (Priv_T))) + elsif No (Discriminant_Specifications (Parent (Priv_T))) and then not Has_Unknown_Discriminants (Priv_T) and then Has_Discriminants (Base_Type (Priv_Parent)) then @@ -14512,8 +14758,13 @@ package body Sem_Ch3 is if Nkind (Subt) = N_Identifier then return Chars (Subt) = Chars (T); + + -- 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))) = Chars (T); else @@ -14638,8 +14889,12 @@ package body Sem_Ch3 is 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. - if Prev /= T then + if Prev /= T + or else Has_Private_Declaration (T) + then return; elsif No (Inc_T) then @@ -14671,6 +14926,7 @@ package body Sem_Ch3 is 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); end if; end if; end Make_Incomplete_Type_Declaration; @@ -14915,6 +15171,15 @@ package body Sem_Ch3 is Final_Storage_Only := not Is_Controlled (T); + -- Ada 2005: check whether an explicit Limited is present in a derived + -- type declaration. + + if Nkind (Parent (Def)) = N_Derived_Type_Definition + and then Limited_Present (Parent (Def)) + then + Set_Is_Limited_Record (T); + end if; + -- If the component list of a record type is defined by the reserved -- word null and there is no discriminant part, then the record type has -- no components and all records of the type are null records (RM 3.7) |