From: Thomas Quinot Date: Wed, 15 Feb 2006 09:44:24 +0000 (+0100) Subject: sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption that Scope_Stack... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=57193e09243103515c50b2b433ddb15a90d311b7;p=gcc.git sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption that Scope_Stack.First = 1. 2006-02-13 Thomas Quinot Robert Dewar Ed Schonberg Javier Miranda * sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption that Scope_Stack.First = 1. Properly handle Ada_Version_Explicit and Ada_Version_Config, which were not always properly handled previously. (Formal_Entity): Complete rewrite, to handle properly some complex case with multiple levels of parametrization by formal packages. (Analyze_Formal_Derived_Type): Propagate Ada 2005 "limited" indicator to the corresponding derived type declaration for proper semantics. * sem_prag.adb (Analyze_Pragma): Remove '!' in warning message. (Check_Component): Enforce restriction on components of unchecked_unions: a component in a variant cannot contain tasks or controlled types. (Unchecked_Union): Allow nested variants and multiple discriminants, to conform to AI-216. Add pragma Ada_2005 (synonym for Ada_05) Properly handle Ada_Version_Explicit and Ada_Version_Config, which were not always properly handled previously. Document that pragma Propagate_Exceptions has no effect (Analyze_Pragma, case Pure): Set new flag Has_Pragma_Pure (Set_Convention_From_Pragma): Check that if a convention is specified for a dispatching operation, then it must be consistent with the existing convention for the operation. (CPP_Class): Because of the C++ ABI compatibility, the programmer is no longer required to specify an vtable-ptr component in the record. For compatibility reasons we leave the support for the previous definition. (Analyze_Pragma, case No_Return): Allow multiple arguments * sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Flag a non-overrideen inherited operation with a controlling result as illegal only its implicit declaration comes from the derived type declaration of its result's type. (Check_Possible_Deferred_Completion): Relocate the object definition node of the subtype indication of a deferred constant completion rather than directly analyzing it. The analysis of the generated subtype will correctly decorate the GNAT tree. (Record_Type_Declaration): Check whether this is a declaration for a limited derived record before analyzing components. (Analyze_Component_Declaration): Diagnose record types not explicitly declared limited when a component has a limited type. (Build_Derived_Record_Type): Code reorganization to check if some of the inherited subprograms of a tagged type cover interface primitives. This check was missing in case of a full-type associated with a private type declaration. (Constant_Redeclaration): Check that the subtypes of the partial and the full view of a constrained deferred constant statically match. (Mentions_T): A reference to the current type in an anonymous access component declaration must be an entity name. (Make_Incomplete_Type_Declaration): If type is tagged, set type of class_wide type to refer to full type, not to the incomplete one. (Add_Interface_Tag_Components): Do nothing if RE_Interface_Tag is not available. Required to give support to the certified run-time. (Analyze_Component_Declaration): In case of anonymous access components perform missing checks for AARM 3.9.2(9) and 3.10.2 (12.2). (Process_Discriminants): For an access discriminant, use the discriminant specification as the associated_node_for_itype, to simplify accessibility checks. From-SVN: r111091 --- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5e8e6dc1d9d..ba3cc95d9c4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.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- -- @@ -1351,6 +1351,7 @@ package body Sem_Ch12 is Subtype_Indication => Subtype_Mark (Def)); Set_Abstract_Present (New_N, Abstract_Present (Def)); + Set_Limited_Present (New_N, Limited_Present (Def)); else New_N := @@ -1364,6 +1365,8 @@ package body Sem_Ch12 is Set_Abstract_Present (Type_Definition (New_N), Abstract_Present (Def)); + Set_Limited_Present + (Type_Definition (New_N), Limited_Present (Def)); end if; Rewrite (N, New_N); @@ -1894,7 +1897,7 @@ package body Sem_Ch12 is Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); begin - if not Present (Ctrl_Type) then + if No (Ctrl_Type) then Error_Msg_N ("abstract formal subprogram must have a controlling type", N); @@ -3030,9 +3033,13 @@ package body Sem_Ch12 is Cunit_Entity (Current_Sem_Unit); Removed : Boolean := False; Num_Scopes : Int := 0; - Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; - Instances : array (1 .. Scope_Stack.Last) of Entity_Id; - Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id; + + Scope_Stack_Depth : constant Int := + Scope_Stack.Last - Scope_Stack.First + 1; + + Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; + Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; + Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; Num_Inner : Int := 0; N_Instances : Int := 0; S : Entity_Id; @@ -6568,16 +6575,23 @@ package body Sem_Ch12 is -- because each actual has the same name as the formal, and they do -- appear in the same order. - function Formal_Entity - (F : Node_Id; - Act_Ent : Entity_Id) return Entity_Id; - -- Returns the entity associated with the given formal F. In the - -- case where F is a formal package, this function will iterate - -- through all of F's formals and enter map associations from the + function Get_Formal_Entity (N : Node_Id) return Entity_Id; + -- Retrieve entity of defining entity of generic formal parameter. + -- Only the declarations of formals need to be considered when + -- linking them to actuals, but the declarative list may include + -- internal entities generated during analysis, and those are ignored. + + procedure Match_Formal_Entity + (Formal_Node : Node_Id; + Formal_Ent : Entity_Id; + Actual_Ent : Entity_Id); + -- Associates the formal entity with the actual. In the case + -- where Formal_Ent is a formal package, this procedure iterates + -- through all of its formals and enters associations betwen the -- actuals occurring in the formal package's corresponding actual - -- package (obtained via Act_Ent) to the formal package's formal - -- parameters. This function is called recursively for arbitrary - -- levels of formal packages. + -- package (given by Actual_Ent) and the formal package's formal + -- parameters. This procedure recurses if any of the parameters is + -- itself a package. function Is_Instance_Of (Act_Spec : Entity_Id; @@ -6641,118 +6655,109 @@ package body Sem_Ch12 is end case; end Find_Matching_Actual; - ------------------- - -- Formal_Entity -- - ------------------- + ------------------------- + -- Match_Formal_Entity -- + ------------------------- - function Formal_Entity - (F : Node_Id; - Act_Ent : Entity_Id) return Entity_Id + procedure Match_Formal_Entity + (Formal_Node : Node_Id; + Formal_Ent : Entity_Id; + Actual_Ent : Entity_Id) is - Orig_Node : Node_Id := F; Act_Pkg : Entity_Id; begin - case Nkind (Original_Node (F)) is - when N_Formal_Object_Declaration => - return Defining_Identifier (F); + Set_Instance_Of (Formal_Ent, Actual_Ent); - when N_Formal_Type_Declaration => - return Defining_Identifier (F); + if Ekind (Actual_Ent) = E_Package then + -- Record associations for each parameter - when N_Formal_Subprogram_Declaration => - return Defining_Unit_Name (Specification (F)); + Act_Pkg := Actual_Ent; - when N_Package_Declaration => - return Defining_Unit_Name (Specification (F)); + declare + A_Ent : Entity_Id := First_Entity (Act_Pkg); + F_Ent : Entity_Id; + F_Node : Node_Id; - when N_Formal_Package_Declaration | - N_Generic_Package_Declaration => + Gen_Decl : Node_Id; + Formals : List_Id; + Actual : Entity_Id; - if Nkind (F) = N_Generic_Package_Declaration then - Orig_Node := Original_Node (F); - end if; + begin + -- Retrieve the actual given in the formal package declaration - Act_Pkg := Act_Ent; + Actual := Entity (Name (Original_Node (Formal_Node))); - -- Find matching actual package, skipping over itypes and - -- other entities generated when analyzing the formal. We - -- know that if the instantiation is legal then there is - -- a matching package for the formal. + -- The actual in the formal package declaration may be a + -- renamed generic package, in which case we want to retrieve + -- the original generic in order to traverse its formal part. - while Ekind (Act_Pkg) /= E_Package loop - Act_Pkg := Next_Entity (Act_Pkg); - end loop; + if Present (Renamed_Entity (Actual)) then + Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); + else + Gen_Decl := Unit_Declaration_Node (Actual); + end if; - declare - Actual_Ent : Entity_Id := First_Entity (Act_Pkg); - Formal_Node : Node_Id; - Formal_Ent : Entity_Id; + Formals := Generic_Formal_Declarations (Gen_Decl); - Gen_Decl : Node_Id; - Formals : List_Id; + if Present (Formals) then + F_Node := First_Non_Pragma (Formals); + else + F_Node := Empty; + end if; - begin - -- The actual may be a renamed generic package, in which - -- case we want to retrieve the original generic in order - -- to traverse its formal part. - - if Present (Renamed_Entity (Entity (Name (Orig_Node)))) then - Gen_Decl := - Unit_Declaration_Node ( - Renamed_Entity (Entity (Name (Orig_Node)))); - else - Gen_Decl := - Unit_Declaration_Node (Entity (Name (Orig_Node))); - end if; + while Present (A_Ent) + and then Present (F_Node) + and then A_Ent /= First_Private_Entity (Act_Pkg) + loop + F_Ent := Get_Formal_Entity (F_Node); - Formals := Generic_Formal_Declarations (Gen_Decl); + if Present (F_Ent) then - if Present (Formals) then - Formal_Node := First_Non_Pragma (Formals); - else - Formal_Node := Empty; + -- This is a formal of the original package. Record + -- association and recurse. + + Find_Matching_Actual (F_Node, A_Ent); + Match_Formal_Entity (F_Node, F_Ent, A_Ent); + Next_Entity (A_Ent); end if; - while Present (Actual_Ent) - and then Present (Formal_Node) - and then Actual_Ent /= First_Private_Entity (Act_Pkg) - loop - -- ??? Are the following calls also needed here: - -- - -- Set_Is_Hidden (Actual_Ent, False); - -- Set_Is_Potentially_Use_Visible - -- (Actual_Ent, In_Use (Act_Ent)); + Next_Non_Pragma (F_Node); + end loop; + end; + end if; + end Match_Formal_Entity; - Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent); - if Present (Formal_Ent) then - Set_Instance_Of (Formal_Ent, Actual_Ent); - end if; - Next_Non_Pragma (Formal_Node); + ----------------------- + -- Get_Formal_Entity -- + ----------------------- - Next_Entity (Actual_Ent); - end loop; - end; + function Get_Formal_Entity (N : Node_Id) return Entity_Id is + Kind : constant Node_Kind := Nkind (Original_Node (N)); + begin + case Kind is + when N_Formal_Object_Declaration => + return Defining_Identifier (N); + + when N_Formal_Type_Declaration => + return Defining_Identifier (N); - return Defining_Identifier (Orig_Node); + when N_Formal_Subprogram_Declaration => + return Defining_Unit_Name (Specification (N)); - when N_Use_Package_Clause => - return Empty; + when N_Formal_Package_Declaration => + return Defining_Identifier (Original_Node (N)); - when N_Use_Type_Clause => - return Empty; + when N_Generic_Package_Declaration => + return Defining_Identifier (Original_Node (N)); - -- We return Empty for all other encountered forms of - -- declarations because there are some cases of nonformal - -- sorts of declaration that can show up (e.g., when array - -- formals are present). Since it's not clear what kinds - -- can appear among the formals, we won't raise failure here. + -- All other declarations are introduced by semantic analysis + -- and have no match in the actual. - when others => + when others => return Empty; - end case; - end Formal_Entity; + end Get_Formal_Entity; -------------------- -- Is_Instance_Of -- @@ -6987,11 +6992,12 @@ package body Sem_Ch12 is end if; if Present (Formal_Node) then - Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent); + Formal_Ent := Get_Formal_Entity (Formal_Node); if Present (Formal_Ent) then Find_Matching_Actual (Formal_Node, Actual_Ent); - Set_Instance_Of (Formal_Ent, Actual_Ent); + Match_Formal_Entity + (Formal_Node, Formal_Ent, Actual_Ent); end if; Next_Non_Pragma (Formal_Node); @@ -8529,7 +8535,7 @@ package body Sem_Ch12 is and then Present (Ancestor_Discr) loop if Base_Type (Act_T) /= Base_Type (Ancestor) and then - not Present (Corresponding_Discriminant (Actual_Discr)) + No (Corresponding_Discriminant (Actual_Discr)) then Error_Msg_NE ("discriminant & does not correspond " & @@ -10444,7 +10450,6 @@ package body Sem_Ch12 is (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), Renamings_Included => True) then Ada_Version := Ada_Version_Type'Last; - Ada_Version_Explicit := Ada_Version_Explicit_Config; end if; Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d2442b44bad..7d706ce71f8 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) diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 95354d60b27..d4d3799396e 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -157,6 +157,11 @@ package Sem_Ch3 is -- Given a discriminant somewhere in the Typ_For_Constraint tree -- and a Constraint, return the value of that discriminant. + function Is_Null_Extension (T : Entity_Id) return Boolean; + -- Returns True if the tagged type T has an N_Full_Type_Declaration that + -- is a null extension, meaning that it has an extension part without any + -- components and does not have a known discriminant part. + function Is_Visible_Component (C : Entity_Id) return Boolean; -- Determines if a record component C is visible in the present context. -- Note that even though component C could appear in the entity chain diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1610c2848a7..bec0eb5e8c0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.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- -- @@ -341,7 +341,7 @@ package body Sem_Prag is procedure Check_Component (Comp : Node_Id); -- Examine Unchecked_Union component for correct use of per-object - -- constrained subtypes. + -- constrained subtypes, and for restrictions on finalizable components. procedure Check_Duplicated_Export_Name (Nam : Node_Id); -- Nam is an N_String_Literal node containing the external name set @@ -988,7 +988,8 @@ package body Sem_Prag is declare Sindic : constant Node_Id := Subtype_Indication (Component_Definition (Comp)); - + Typ : constant Entity_Id := + Etype (Defining_Identifier (Comp)); begin if Nkind (Sindic) = N_Subtype_Indication then @@ -1004,6 +1005,15 @@ package body Sem_Prag is " constraint must be an Unchecked_Union", Comp); end if; end if; + + if Is_Controlled (Typ) then + Error_Msg_N + ("component of unchecked union cannot be controlled", Comp); + + elsif Has_Task (Typ) then + Error_Msg_N + ("component of unchecked union cannot have tasks", Comp); + end if; end; end if; end Check_Component; @@ -1440,12 +1450,6 @@ package body Sem_Prag is Comp : Node_Id; begin - if Present (Variant_Part (Clist)) then - Error_Msg_N - ("Unchecked_Union may not have nested variants", - Variant_Part (Clist)); - end if; - if not Is_Non_Empty_List (Component_Items (Clist)) then Error_Msg_N ("Unchecked_Union may not have empty component list", @@ -1957,6 +1961,24 @@ package body Sem_Prag is procedure Set_Convention_From_Pragma (E : Entity_Id) is begin + -- Check invalid attempt to change convention for an overridden + -- dispatching operation. This is Ada 2005 AI 430. Technically + -- this is an amendment and should only be done in Ada 2005 mode. + -- However, this is clearly a mistake, since the problem that is + -- addressed by this AI is that there is a clear gap in the RM! + + if Is_Dispatching_Operation (E) + and then Present (Overridden_Operation (E)) + and then C /= Convention (Overridden_Operation (E)) + then + Error_Pragma_Arg + ("cannot change convention for " & + "overridden dispatching operation", + Arg1); + end if; + + -- Set the convention + Set_Convention (E, C); Set_Has_Convention_Pragma (E); @@ -2862,7 +2884,7 @@ package body Sem_Prag is else Dval := Default_Value (Formal); - if not Present (Dval) then + if No (Dval) then Error_Msg_NE ("optional formal& does not have default value!", Arg_First_Optional_Parameter, Formal); @@ -4222,9 +4244,9 @@ package body Sem_Prag is Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); - -- Set the FIFO_Within_Priorities policy, but always - -- preserve System_Location since we like the error - -- message with the run time name. + -- Set the FIFO_Within_Priorities policy, but always preserve + -- System_Location since we like the error message with the run time + -- name. else Task_Dispatching_Policy := 'F'; @@ -4242,9 +4264,8 @@ package body Sem_Prag is Error_Msg_Sloc := Locking_Policy_Sloc; Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); - -- Set the Ceiling_Locking policy, but always preserve - -- System_Location since we like the error message with the - -- run time name. + -- Set the Ceiling_Locking policy, but preserve System_Location since + -- we like the error message with the run time name. else Locking_Policy := 'C'; @@ -4268,7 +4289,7 @@ package body Sem_Prag is begin if not Is_Pragma_Name (Chars (N)) then if Warn_On_Unrecognized_Pragma then - Error_Pragma ("unrecognized pragma%!?"); + Error_Pragma ("unrecognized pragma%?"); else return; end if; @@ -4368,17 +4389,20 @@ package body Sem_Prag is Ada_Version_Explicit := Ada_Version; Check_Arg_Count (0); - ------------ - -- Ada_05 -- - ------------ + --------------------- + -- Ada_05/Ada_2005 -- + --------------------- -- pragma Ada_05; -- pragma Ada_05 (LOCAL_NAME); - -- Note: this pragma also has some specific processing in Par.Prag + -- pragma Ada_2005; + -- pragma Ada_2005 (LOCAL_NAME): + + -- Note: these pragma also have some specific processing in Par.Prag -- because we want to set the Ada 2005 version mode during parsing. - when Pragma_Ada_05 => declare + when Pragma_Ada_05 | Pragma_Ada_2005 => declare E_Id : Node_Id; begin @@ -4397,7 +4421,7 @@ package body Sem_Prag is else Check_Arg_Count (0); Ada_Version := Ada_05; - Ada_Version_Explicit := Ada_Version; + Ada_Version_Explicit := Ada_05; end if; end; @@ -4618,7 +4642,7 @@ package body Sem_Prag is procedure Process_Async_Pragma is begin - if not Present (L) then + if No (L) then Set_Is_Asynchronous (Nm); return; end if; @@ -5255,16 +5279,15 @@ package body Sem_Prag is ("only tagged records can contain vtable pointers", Arg1); end if; - -- Case of tagged type with no vtable ptr - - -- What is test for Typ = Root_Typ (Typ) about here ??? + -- Case of tagged type with no user-defined vtable ptr. In this + -- case, because of our C++ ABI compatibility, the programmer + -- does not need to specify the tag component. elsif Is_Tagged_Type (Typ) - and then Typ = Root_Type (Typ) and then No (Default_DTC) then - Error_Pragma_Arg - ("a cpp_class must contain a vtable pointer", Arg1); + Set_Is_CPP_Class (Typ); + Set_Is_Limited_Record (Typ); -- Tagged type that has a vtable ptr @@ -5438,6 +5461,8 @@ package body Sem_Prag is Next_Component (DTC); end loop; + -- Case of tagged type with no user-defined vtable ptr + if No (DTC) then Error_Msg_NE ("must be a& component name", Arg, Typ); raise Pragma_Exit; @@ -8101,48 +8126,57 @@ package body Sem_Prag is -- No_Return -- --------------- - -- pragma No_Return (procedure_LOCAL_NAME); + -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); when Pragma_No_Return => No_Return : declare Id : Node_Id; E : Entity_Id; Found : Boolean; + Arg : Node_Id; begin GNAT_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_Local_Name (Arg1); - Id := Expression (Arg1); - Analyze (Id); + Check_At_Least_N_Arguments (1); - if not Is_Entity_Name (Id) then - Error_Pragma_Arg ("entity name required", Arg1); - end if; + -- Loop through arguments of pragma - if Etype (Id) = Any_Type then - raise Pragma_Exit; - end if; + Arg := Arg1; + while Present (Arg) loop + Check_Arg_Is_Local_Name (Arg); + Id := Expression (Arg); + Analyze (Id); - E := Entity (Id); + if not Is_Entity_Name (Id) then + Error_Pragma_Arg ("entity name required", Arg); + end if; - Found := False; - while Present (E) - and then Scope (E) = Current_Scope - loop - if Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Procedure - then - Set_No_Return (E); - Found := True; + if Etype (Id) = Any_Type then + raise Pragma_Exit; end if; - E := Homonym (E); - end loop; + -- Loop to find matching procedures - if not Found then - Error_Pragma ("no procedures found for pragma%"); - end if; + E := Entity (Id); + Found := False; + while Present (E) + and then Scope (E) = Current_Scope + loop + if Ekind (E) = E_Procedure + or else Ekind (E) = E_Generic_Procedure + then + Set_No_Return (E); + Found := True; + end if; + + E := Homonym (E); + end loop; + + if not Found then + Error_Pragma_Arg ("no procedure & found for pragma%", Arg); + end if; + + Next (Arg); + end loop; end No_Return; ------------------------ @@ -8181,7 +8215,7 @@ package body Sem_Prag is -- Obsolescent -- ----------------- - -- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])]; + -- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])]; when Pragma_Obsolescent => Obsolescent : declare Subp : Node_Or_Entity_Id; @@ -8789,6 +8823,8 @@ package body Sem_Prag is -- pragma Propagate_Exceptions; + -- Note: this pragma is obsolete and has no effect + when Pragma_Propagate_Exceptions => GNAT_Pragma; Check_Arg_Count (0); @@ -8956,6 +8992,7 @@ package body Sem_Prag is Ent := Find_Lib_Unit_Name; Set_Is_Pure (Ent); + Set_Has_Pragma_Pure (Ent); Set_Suppress_Elaboration_Warnings (Ent); end Pure; @@ -10146,18 +10183,14 @@ package body Sem_Prag is Discr := First_Discriminant (Typ); - if Present (Next_Discriminant (Discr)) then - Error_Msg_N - ("Unchecked_Union must have exactly one discriminant", - Next_Discriminant (Discr)); - return; - end if; - - if No (Discriminant_Default_Value (Discr)) then - Error_Msg_N - ("Unchecked_Union discriminant must have default value", - Discr); - end if; + while Present (Discr) loop + if No (Discriminant_Default_Value (Discr)) then + Error_Msg_N + ("Unchecked_Union discriminant must have default value", + Discr); + end if; + Next_Discriminant (Discr); + end loop; Tdef := Type_Definition (Declaration_Node (Typ)); Clist := Component_List (Tdef); @@ -10686,6 +10719,7 @@ package body Sem_Prag is Pragma_Ada_83 => -1, Pragma_Ada_95 => -1, Pragma_Ada_05 => -1, + Pragma_Ada_2005 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1,