[Ada] Missing inheritance of pragma Default_Initial_Condition

Message ID	20141017083501.GA32528@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-380897-incoming=patchwork.ozlabs.org@gcc.gnu.org> DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=QR7Gg495IFgpezSxM5ej246PBB2nzoLuXwVgb/bxfXXaqEMlYD OznBffJ6jRL5r/X9M0dZapVQrzu881FlfCbLlTh2R/NBitgJoIbvIf8EY+4AEP1Y RMm4sxlPT5VOaCl4yU3wZ2TzXTXI2La7/WjzITdpWAi88CRVg51d/17S8= Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org Date: Fri, 17 Oct 2014 04:35:01 -0400 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev <kirtchev@adacore.com> Subject: [Ada] Missing inheritance of pragma Default_Initial_Condition Message-ID: <20141017083501.GA32528@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="mYCpIKhGyMATD0i+" Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15)

Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 216367) +++ sem_ch3.adb (working copy) @@ -650,6 +650,17 @@ -- present. If errors are found, error messages are posted, and the -- Real_Range_Specification of Def is reset to Empty. + procedure Propagate_Default_Init_Cond_Attributes + (From_Typ : Entity_Id; + To_Typ : Entity_Id; + Parent_To_Derivation : Boolean := False; + Private_To_Full_View : Boolean := False); + -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit + -- all attributes related to pragma Default_Initial_Condition from From_Typ + -- to To_Typ. Flag Parent_To_Derivation should be set when the context is + -- the creation of a derived type. Flag Private_To_Full_View should be set + -- when processing both views of a private type. + procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id; @@ -8546,23 +8557,6 @@ end if; Check_Function_Writable_Actuals (N); - - -- Propagate the attributes related to pragma Default_Initial_Condition - -- from the parent type to the private extension. A derived type always - -- inherits the default initial condition flag from the parent type. If - -- the derived type carries its own Default_Initial_Condition pragma, - -- the flag is later reset in Analyze_Pragma. Note that both flags are - -- mutually exclusive. - - if Has_Inherited_Default_Init_Cond (Parent_Type) - or else Present (Get_Pragma - (Parent_Type, Pragma_Default_Initial_Condition)) - then - Set_Has_Inherited_Default_Init_Cond (Derived_Type); - - elsif Has_Default_Init_Cond (Parent_Type) then - Set_Has_Default_Init_Cond (Derived_Type); - end if; end Build_Derived_Record_Type; ------------------------ @@ -8680,6 +8674,18 @@ Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); end if; + -- Propagate the attributes related to pragma Default_Initial_Condition + -- from the parent type to the private extension. A derived type always + -- inherits the default initial condition flag from the parent type. If + -- the derived type carries its own Default_Initial_Condition pragma, + -- the flag is later reset in Analyze_Pragma. Note that both flags are + -- mutually exclusive. + + Propagate_Default_Init_Cond_Attributes + (From_Typ => Parent_Type, + To_Typ => Derived_Type, + Parent_To_Derivation => True); + -- If the parent type has delayed rep aspects, then mark the derived -- type as possibly inheriting a delayed rep aspect. @@ -10008,6 +10014,401 @@ end if; end Check_Aliased_Component_Types; + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- + + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ_Decl); + Anon_Access : Entity_Id; + Acc_Def : Node_Id; + Comp : Node_Id; + Comp_Def : Node_Id; + Decl : Node_Id; + Type_Def : Node_Id; + + procedure Build_Incomplete_Type_Declaration; + -- If the record type contains components that include an access to the + -- current record, then create an incomplete type declaration for the + -- record, to be used as the designated type of the anonymous access. + -- This is done only once, and only if there is no previous partial + -- view of the type. + + function Designates_T (Subt : Node_Id) return Boolean; + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type + + function Mentions_T (Acc_Def : Node_Id) return Boolean; + -- Check whether an access definition includes a reference to + -- the enclosing record type. The reference can be a subtype mark + -- in the access definition itself, a 'Class attribute reference, or + -- recursively a reference appearing in a parameter specification + -- or result definition of an access_to_subprogram definition. + + -------------------------------------- + -- Build_Incomplete_Type_Declaration -- + -------------------------------------- + + procedure Build_Incomplete_Type_Declaration is + Decl : Node_Id; + Inc_T : Entity_Id; + H : Entity_Id; + + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". + + Is_Tagged : constant Boolean := + (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else + (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Typ_Decl))); + + begin + -- If there is a previous partial view, no need to create a new one + -- If the partial view, given by Prev, is incomplete, If Prev is + -- a private declaration, full declaration is flagged accordingly. + + if Prev /= Typ then + if Is_Tagged then + Make_Class_Wide_Type (Prev); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; + + return; + + elsif Has_Private_Declaration (Typ) then + + -- If we refer to T'Class inside T, and T is the completion of a + -- private type, then make sure the class-wide type exists. + + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; + + return; + + -- If there was a previous anonymous access type, the incomplete + -- type declaration will have been created already. + + elsif Present (Current_Entity (Typ)) + and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type + and then Full_View (Current_Entity (Typ)) = Typ + then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged??", + Parent (Current_Entity (Typ))); + end if; + return; + + else + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + + -- Type has already been inserted into the current scope. Remove + -- it, and add incomplete declaration for type, so that subsequent + -- anonymous access types can use it. The entity is unchained from + -- the homonym list and from immediate visibility. After analysis, + -- the entity in the incomplete declaration becomes immediately + -- visible in the record declaration that follows. + + H := Current_Entity (Typ); + + if H = Typ then + Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); + else + while Present (H) + and then Homonym (H) /= Typ + loop + H := Homonym (Typ); + end loop; + + Set_Homonym (H, Homonym (Typ)); + end if; + + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, Typ); + + if Is_Tagged then + + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. + + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); + Set_Etype (Class_Wide_Type (Typ), Typ); + end if; + end if; + end Build_Incomplete_Type_Declaration; + + ------------------ + -- Designates_T -- + ------------------ + + function Designates_T (Subt : Node_Id) return Boolean is + 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. + + ------------- + -- Names_T -- + ------------- + + 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; + + -- Start of processing for Designates_T + + begin + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; + + -- Reference can be through an expanded name which has not been + -- analyzed yet, and which designates enclosing scopes. + + elsif Nkind (Subt) = N_Selected_Component then + 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. + + else + Find_Selected_Component (Subt); + return + Is_Entity_Name (Subt) + and then Scope (Entity (Subt)) = Current_Scope + and then + (Chars (Base_Type (Entity (Subt))) = Type_Id + or else + (Is_Class_Wide_Type (Entity (Subt)) + and then + Chars (Etype (Base_Type (Entity (Subt)))) = + Type_Id)); + end if; + + -- 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 + then + return Names_T (Prefix (Subt)); + + else + return False; + end if; + end Designates_T; + + ---------------- + -- Mentions_T -- + ---------------- + + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Param_Spec : Node_Id; + + Acc_Subprg : constant Node_Id := + Access_To_Subprogram_Definition (Acc_Def); + + begin + if No (Acc_Subprg) then + return Designates_T (Subtype_Mark (Acc_Def)); + end if; + + -- Component is an access_to_subprogram: examine its formals, + -- and result definition in the case of an access_to_function. + + Param_Spec := First (Parameter_Specifications (Acc_Subprg)); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; + + elsif Designates_T (Parameter_Type (Param_Spec)) then + return True; + end if; + + Next (Param_Spec); + end loop; + + if Nkind (Acc_Subprg) = N_Access_Function_Definition then + if Nkind (Result_Definition (Acc_Subprg)) = + N_Access_Definition + then + return Mentions_T (Result_Definition (Acc_Subprg)); + else + return Designates_T (Result_Definition (Acc_Subprg)); + end if; + end if; + + return False; + end Mentions_T; + + -- Start of processing for Check_Anonymous_Access_Components + + begin + if No (Comp_List) then + return; + end if; + + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Present + (Access_Definition (Component_Definition (Comp))) + and then + Mentions_T (Access_Definition (Component_Definition (Comp))) + then + Comp_Def := Component_Definition (Comp); + Acc_Def := + Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); + + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); + + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. + + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); + else + Type_Def := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); + end if; + + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + 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; + + 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); + + -- If an access to subprogram, create the extra formals + + if Present (Acc_Def) then + Create_Extra_Formals (Designated_Type (Anon_Access)); + + -- If an access to object, preserve entity of designated type, + -- for ASIS use, before rewriting the component definition. + + else + declare + Desig : Entity_Id; + + begin + Desig := Entity (Subtype_Indication (Type_Def)); + + -- If the access definition is to the current record, + -- the visible entity at this point is an incomplete + -- type. Retrieve the full view to simplify ASIS queries + + if Ekind (Desig) = E_Incomplete_Type then + Desig := Full_View (Desig); + end if; + + Set_Entity + (Subtype_Mark (Access_Definition (Comp_Def)), Desig); + end; + end if; + + Rewrite (Comp_Def, + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Anon_Access, Loc))); + + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); + end if; + + Next (Comp); + end loop; + + if Present (Variant_Part (Comp_List)) then + declare + V : Node_Id; + begin + V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (V) loop + Check_Anonymous_Access_Components + (Typ_Decl, Typ, Prev, Component_List (V)); + Next_Non_Pragma (V); + end loop; + end; + end if; + end Check_Anonymous_Access_Components; + ---------------------- -- Check_Completion -- ---------------------- @@ -10051,6 +10452,7 @@ if not Comes_From_Source (E) then if Ekind_In (E, E_Task_Type, E_Protected_Type) then + -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. @@ -10175,10 +10577,10 @@ -- this kind is reserved for predefined operators, that are -- intrinsic and do not need completion. - elsif Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Procedure + elsif Ekind_In (E, E_Function, + E_Procedure, + E_Generic_Function, + E_Generic_Procedure) then if Has_Completion (E) then null; @@ -10237,8 +10639,7 @@ then Post_Error; - elsif (Ekind (E) = E_Task_Type or else - Ekind (E) = E_Protected_Type) + elsif Ekind_In (E, E_Task_Type, E_Protected_Type) and then not Has_Completion (E) then Post_Error; @@ -10459,8 +10860,8 @@ -- Set True if parent type or any progenitor is a protected interface procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); - -- Check that a progenitor is compatible with declaration. - -- Error is posted on Error_Node. + -- Check that a progenitor is compatible with declaration. If an error + -- message is output, it is posted on Error_Node. ------------------ -- Check_Ifaces -- @@ -10507,8 +10908,8 @@ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition and then not Interface_Present (Type_Definition (N)) then - Error_Msg_N ("record extension cannot derive from synchronized" - & " interface", Error_Node); + Error_Msg_N ("record extension cannot derive from synchronized " + & "interface", Error_Node); end if; end if; @@ -10526,7 +10927,7 @@ and then not Is_Limited_Interface (Iface_Id) then Error_Msg_NE - ("progenitor& must be limited interface", + ("progenitor & must be limited interface", Error_Node, Iface_Id); elsif @@ -10537,7 +10938,7 @@ and then not Error_Posted (N) then Error_Msg_NE - ("progenitor& must be limited interface", + ("progenitor & must be limited interface", Error_Node, Iface_Id); end if; @@ -10554,12 +10955,12 @@ null; elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from task interface", Error_Node); else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from non-limited interface", Error_Node); end if; -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from @@ -10574,18 +10975,18 @@ elsif Protected_Present (Iface_Def) and then Nkind (N) /= N_Private_Extension_Declaration then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from protected interface", Error_Node); + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from protected interface", Error_Node); elsif Task_Present (Iface_Def) and then Nkind (N) /= N_Private_Extension_Declaration then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from task interface", Error_Node); + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from task interface", Error_Node); elsif not Is_Limited_Interface (Iface_Id) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from non-limited interface", Error_Node); end if; -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, @@ -10601,12 +11002,12 @@ null; elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " protected interface", Error_Node); + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "protected interface", Error_Node); else - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " non-limited interface", Error_Node); + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "non-limited interface", Error_Node); end if; end if; end Check_Ifaces; @@ -10636,7 +11037,6 @@ if not Is_Interface (Iface_Typ) then Diagnose_Interface (Iface, Iface_Typ); - else Check_Ifaces (Iface_Def, Iface); end if; @@ -10724,8 +11124,8 @@ -- Entity of corresponding discriminant on partial view New_D : Node_Id; - -- Discriminant specification for full view, expression is the - -- syntactic copy on full view (which has been checked for + -- Discriminant specification for full view, expression is + -- the syntactic copy on full view (which has been checked for -- conformance with partial view), only used here to post error -- message. @@ -10753,8 +11153,8 @@ then if Ada_Version >= Ada_2012 then Error_Msg_N - ("discriminants of nonlimited tagged type cannot have" - & " defaults", + ("discriminants of nonlimited tagged type cannot have " + & "defaults", Expression (New_D)); else Error_Msg_N @@ -10823,14 +11223,14 @@ begin -- Set semantic attributes for (implicit) private subtype completion. - -- If the full type has no discriminants, then it is a copy of the full - -- view of the base. Otherwise, it is a subtype of the base with a - -- possible discriminant constraint. Save and restore the original - -- Next_Entity field of full to ensure that the calls to Copy_Node - -- do not corrupt the entity chain. + -- If the full type has no discriminants, then it is a copy of the + -- full view of the base. Otherwise, it is a subtype of the base with + -- a possible discriminant constraint. Save and restore the original + -- Next_Entity field of full to ensure that the calls to Copy_Node do + -- not corrupt the entity chain. - -- Note that the type of the full view is the same entity as the type of - -- the partial view. In this fashion, the subtype has access to the + -- Note that the type of the full view is the same entity as the type + -- of the partial view. In this fashion, the subtype has access to the -- correct view of the parent. Save_Next_Entity := Next_Entity (Full); @@ -10878,11 +11278,10 @@ Set_Convention (Full, Convention (Full_Base)); -- The Etype of the full view is inconsistent. Gigi needs to see the - -- structural full view, which is what the current scheme gives: - -- the Etype of the full view is the etype of the full base. However, - -- if the full base is a derived type, the full view then looks like - -- a subtype of the parent, not a subtype of the full base. If instead - -- we write: + -- structural full view, which is what the current scheme gives: the + -- Etype of the full view is the etype of the full base. However, if the + -- full base is a derived type, the full view then looks like a subtype + -- of the parent, not a subtype of the full base. If instead we write: -- Set_Etype (Full, Full_Base); @@ -11065,7 +11464,6 @@ elsif Item /= First_Rep_Item (Priv) then Append := True; - loop Next_Item := Next_Rep_Item (Item); exit when No (Next_Item); @@ -11158,8 +11556,8 @@ 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); + Error_Msg_N ("subtype does not statically match deferred " + & "declaration #", N); end if; end; end if; @@ -11183,7 +11581,7 @@ then Error_Msg_Sloc := Sloc (Parent (Comp)); Error_Msg_NE - ("illegal circularity with declaration for&#", + ("illegal circularity with declaration for & #", N, Comp); return; @@ -11304,7 +11702,7 @@ and then not Aliased_Present (N) then Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("ALIASED required (see declaration#)", N); + Error_Msg_N ("ALIASED required (see declaration #)", N); end if; -- Check that placement is in private part and that the incomplete @@ -11399,8 +11797,7 @@ -- types, unlike the rule concerning default discriminants (see -- RM 3.7.1(7/3)) - if (Ekind (T) = E_General_Access_Type - or else Ada_Version >= Ada_2005) + if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005) and then Has_Private_Declaration (Desig_Type) and then In_Open_Scopes (Scope (Desig_Type)) and then Has_Discriminants (Desig_Type) @@ -11417,9 +11814,8 @@ Decl := First (Decls); while Present (Decl) loop if (Nkind (Decl) = N_Private_Type_Declaration - and then - Chars (Defining_Identifier (Decl)) = - Chars (Desig_Type)) + and then Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type)) or else (Nkind (Decl) = N_Full_Type_Declaration @@ -11432,8 +11828,8 @@ then if No (Discriminant_Specifications (Decl)) then Error_Msg_N - ("cannot constrain access type if designated " & - "type has constrained partial view", S); + ("cannot constrain access type if designated " + & "type has constrained partial view", S); end if; exit; @@ -11448,15 +11844,14 @@ Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, For_Access => True); - elsif (Is_Task_Type (Desig_Type) - or else Is_Protected_Type (Desig_Type)) + elsif (Is_Task_Type (Desig_Type) or else Is_Protected_Type (Desig_Type)) and then not Is_Constrained (Desig_Type) then Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); else Error_Msg_N ("invalid constraint on access type", S); - Desig_Subtype := Desig_Type; -- Ignore invalid constraint. + Desig_Subtype := Desig_Type; -- Ignore invalid constraint Constraint_OK := False; end if; @@ -11512,8 +11907,8 @@ then if Ada_Version < Ada_2005 then Error_Msg_N - ("access subtype would not be allowed in generic body " & - "in Ada 2005?y?", S); + ("access subtype would not be allowed in generic body " + & "in Ada 2005?y?", S); else Error_Msg_N ("access subtype not allowed in generic body", S); @@ -17952,9 +18347,43 @@ Set_Small_Value (T, Small_Val); Set_Delta_Value (T, Delta_Val); Set_Is_Constrained (T); - end Ordinary_Fixed_Point_Type_Declaration; + ---------------------------------- + -- Preanalyze_Assert_Expression -- + ---------------------------------- + + procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is + begin + In_Assertion_Expr := In_Assertion_Expr + 1; + Preanalyze_Spec_Expression (N, T); + In_Assertion_Expr := In_Assertion_Expr - 1; + end Preanalyze_Assert_Expression; + + ----------------------------------- + -- Preanalyze_Default_Expression -- + ----------------------------------- + + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Default_Expr : constant Boolean := In_Default_Expr; + begin + In_Default_Expr := True; + Preanalyze_Spec_Expression (N, T); + In_Default_Expr := Save_In_Default_Expr; + end Preanalyze_Default_Expression; + + -------------------------------- + -- Preanalyze_Spec_Expression -- + -------------------------------- + + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Spec_Expression; + ---------------------------------------- -- Prepare_Private_Subtype_Completion -- ---------------------------------------- @@ -18324,10 +18753,6 @@ ----------------------- procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is - Priv_Parent : Entity_Id; - Full_Parent : Entity_Id; - Full_Indic : Node_Id; - procedure Collect_Implemented_Interfaces (Typ : Entity_Id; Ifaces : Elist_Id); @@ -18419,6 +18844,12 @@ end if; end Collect_Implemented_Interfaces; + -- Local variables + + Full_Indic : Node_Id; + Full_Parent : Entity_Id; + Priv_Parent : Entity_Id; + -- Start of processing for Process_Full_View begin @@ -19011,15 +19442,40 @@ -- from the private to the full view. Note that both flags are mutually -- exclusive. - if Has_Inherited_Default_Init_Cond (Priv_T) then - Set_Has_Inherited_Default_Init_Cond (Full_T); - Set_Default_Init_Cond_Procedure - (Full_T, Default_Init_Cond_Procedure (Priv_T)); + if Has_Default_Init_Cond (Priv_T) + or else Has_Inherited_Default_Init_Cond (Priv_T) + then + Propagate_Default_Init_Cond_Attributes + (From_Typ => Priv_T, + To_Typ => Full_T, + Private_To_Full_View => True); - elsif Has_Default_Init_Cond (Priv_T) then - Set_Has_Default_Init_Cond (Full_T); - Set_Default_Init_Cond_Procedure - (Full_T, Default_Init_Cond_Procedure (Priv_T)); + -- In the case where the full view is derived from another private type, + -- the attributes related to pragma Default_Initial_Condition must be + -- propagated from the full to the private view to maintain consistency + -- of views. + + -- package Pack is + -- type Parent_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Parent_Typ is ...; + -- end Pack; + + -- with Pack; use Pack; + -- package Pack_2 is + -- type Deriv_Typ is private; -- must inherit + -- private + -- type Deriv_Typ is new Parent_Typ; -- must inherit + -- end Pack_2; + + elsif Has_Default_Init_Cond (Full_T) + or else Has_Inherited_Default_Init_Cond (Full_T) + then + Propagate_Default_Init_Cond_Attributes + (From_Typ => Full_T, + To_Typ => Priv_T, + Private_To_Full_View => True); end if; -- Propagate invariants to full type @@ -19883,440 +20339,115 @@ end if; end Process_Subtype; - --------------------------------------- - -- Check_Anonymous_Access_Components -- - --------------------------------------- + -------------------------------------------- + -- Propagate_Default_Init_Cond_Attributes -- + -------------------------------------------- - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id) + procedure Propagate_Default_Init_Cond_Attributes + (From_Typ : Entity_Id; + To_Typ : Entity_Id; + Parent_To_Derivation : Boolean := False; + Private_To_Full_View : Boolean := False) is - Loc : constant Source_Ptr := Sloc (Typ_Decl); - Anon_Access : Entity_Id; - Acc_Def : Node_Id; - Comp : Node_Id; - Comp_Def : Node_Id; - Decl : Node_Id; - Type_Def : Node_Id; + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id); + -- Remove the default initial procedure (if any) from the rep chain of + -- type Typ. - procedure Build_Incomplete_Type_Declaration; - -- If the record type contains components that include an access to the - -- current record, then create an incomplete type declaration for the - -- record, to be used as the designated type of the anonymous access. - -- This is done only once, and only if there is no previous partial - -- view of the type. + ---------------------------------------- + -- Remove_Default_Init_Cond_Procedure -- + ---------------------------------------- - function Designates_T (Subt : Node_Id) return Boolean; - -- Check whether a node designates the enclosing record type, or 'Class - -- of that type + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is + Found : Boolean := False; + Prev : Entity_Id; + Subp : Entity_Id; - function Mentions_T (Acc_Def : Node_Id) return Boolean; - -- Check whether an access definition includes a reference to - -- the enclosing record type. The reference can be a subtype mark - -- in the access definition itself, a 'Class attribute reference, or - -- recursively a reference appearing in a parameter specification - -- or result definition of an access_to_subprogram definition. - - -------------------------------------- - -- Build_Incomplete_Type_Declaration -- - -------------------------------------- - - procedure Build_Incomplete_Type_Declaration is - Decl : Node_Id; - Inc_T : Entity_Id; - H : Entity_Id; - - -- Is_Tagged indicates whether the type is tagged. It is tagged if - -- it's "is new ... with record" or else "is tagged record ...". - - Is_Tagged : constant Boolean := - (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present - (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else - (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition - and then Tagged_Present (Type_Definition (Typ_Decl))); - begin - -- If there is a previous partial view, no need to create a new one - -- If the partial view, given by Prev, is incomplete, If Prev is - -- a private declaration, full declaration is flagged accordingly. - - if Prev /= Typ then - if Is_Tagged then - Make_Class_Wide_Type (Prev); - Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); - Set_Etype (Class_Wide_Type (Typ), Typ); + Prev := Typ; + Subp := Subprograms_For_Type (Typ); + while Present (Subp) loop + if Is_Default_Init_Cond_Procedure (Subp) then + Found := True; + exit; end if; - return; + Prev := Subp; + Subp := Subprograms_For_Type (Subp); + end loop; - elsif Has_Private_Declaration (Typ) then - - -- If we refer to T'Class inside T, and T is the completion of a - -- private type, then we need to make sure the class-wide type - -- exists. - - if Is_Tagged then - Make_Class_Wide_Type (Typ); - end if; - - return; - - -- If there was a previous anonymous access type, the incomplete - -- type declaration will have been created already. - - elsif Present (Current_Entity (Typ)) - and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type - and then Full_View (Current_Entity (Typ)) = Typ - then - if Is_Tagged - and then Comes_From_Source (Current_Entity (Typ)) - and then not Is_Tagged_Type (Current_Entity (Typ)) - then - Make_Class_Wide_Type (Typ); - Error_Msg_N - ("incomplete view of tagged type should be declared tagged??", - Parent (Current_Entity (Typ))); - end if; - return; - - else - Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); - Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - - -- Type has already been inserted into the current scope. Remove - -- it, and add incomplete declaration for type, so that subsequent - -- anonymous access types can use it. The entity is unchained from - -- the homonym list and from immediate visibility. After analysis, - -- the entity in the incomplete declaration becomes immediately - -- visible in the record declaration that follows. - - H := Current_Entity (Typ); - - if H = Typ then - Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); - else - while Present (H) - and then Homonym (H) /= Typ - loop - H := Homonym (Typ); - end loop; - - Set_Homonym (H, Homonym (Typ)); - end if; - - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); - Set_Full_View (Inc_T, Typ); - - if Is_Tagged then - - -- Create a common class-wide type for both views, and set the - -- Etype of the class-wide type to the full view. - - Make_Class_Wide_Type (Inc_T); - Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); - Set_Etype (Class_Wide_Type (Typ), Typ); - end if; + if Found then + Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp)); + Set_Subprograms_For_Type (Subp, Empty); end if; - end Build_Incomplete_Type_Declaration; + end Remove_Default_Init_Cond_Procedure; - ------------------ - -- Designates_T -- - ------------------ + -- Local variables - function Designates_T (Subt : Node_Id) return Boolean is - Type_Id : constant Name_Id := Chars (Typ); + Inherit_Procedure : Boolean := False; - 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. + -- Start of processing for Propagate_Default_Init_Cond_Attributes - ------------- - -- Names_T -- - ------------- + begin + -- A full view inherits the attributes from its private view - function Names_T (Nam : Node_Id) return Boolean is - begin - if Nkind (Nam) = N_Identifier then - return Chars (Nam) = Type_Id; + if Has_Default_Init_Cond (From_Typ) then + Set_Has_Default_Init_Cond (To_Typ); + Inherit_Procedure := True; - 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); + -- Due to the order of expansion, a derived private type is processed + -- by two routines which both attempt to set the attributes related + -- to pragma Default_Initial_Condition - Build_Derived_Type and then + -- Process_Full_View. - elsif Nkind (Prefix (Nam)) = N_Selected_Component then - return Chars (Selector_Name (Prefix (Nam))) = - Chars (Current_Scope); - else - return False; - end if; + -- package Pack is + -- type Parent_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Parent_Typ is ...; + -- end Pack; - else - return False; - end if; + -- with Pack; use Pack; + -- package Pack_2 is + -- type Deriv_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Deriv_Typ is new Parent_Typ; + -- end Pack_2; - else - return False; - end if; - end Names_T; + -- When Build_Derived_Type operates, it sets the attributes on the + -- full view without taking into account that the private view may + -- define its own default initial condition procedure. This becomes + -- apparent in Process_Full_View which must undo some of the work by + -- Build_Derived_Type and propagate the attributes from the private + -- to the full view. - -- Start of processing for Designates_T - - begin - if Nkind (Subt) = N_Identifier then - return Chars (Subt) = Type_Id; - - -- Reference can be through an expanded name which has not been - -- analyzed yet, and which designates enclosing scopes. - - elsif Nkind (Subt) = N_Selected_Component then - 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. - - else - Find_Selected_Component (Subt); - return - Is_Entity_Name (Subt) - and then Scope (Entity (Subt)) = Current_Scope - and then - (Chars (Base_Type (Entity (Subt))) = Type_Id - or else - (Is_Class_Wide_Type (Entity (Subt)) - and then - Chars (Etype (Base_Type (Entity (Subt)))) = - Type_Id)); - end if; - - -- 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 - then - return Names_T (Prefix (Subt)); - - else - return False; + if Private_To_Full_View then + Set_Has_Inherited_Default_Init_Cond (To_Typ, False); + Remove_Default_Init_Cond_Procedure (To_Typ); end if; - end Designates_T; - ---------------- - -- Mentions_T -- - ---------------- + -- A type must inherit the default initial condition procedure from a + -- parent type when the parent itself is inheriting the procedure or + -- when it is defining one. This circuitry is also used when dealing + -- with the private / full view of a type. - function Mentions_T (Acc_Def : Node_Id) return Boolean is - Param_Spec : Node_Id; - - Acc_Subprg : constant Node_Id := - Access_To_Subprogram_Definition (Acc_Def); - - begin - if No (Acc_Subprg) then - return Designates_T (Subtype_Mark (Acc_Def)); - end if; - - -- Component is an access_to_subprogram: examine its formals, - -- and result definition in the case of an access_to_function. - - Param_Spec := First (Parameter_Specifications (Acc_Subprg)); - while Present (Param_Spec) loop - if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition - and then Mentions_T (Parameter_Type (Param_Spec)) - then - return True; - - elsif Designates_T (Parameter_Type (Param_Spec)) then - return True; - end if; - - Next (Param_Spec); - end loop; - - if Nkind (Acc_Subprg) = N_Access_Function_Definition then - if Nkind (Result_Definition (Acc_Subprg)) = - N_Access_Definition - then - return Mentions_T (Result_Definition (Acc_Subprg)); - else - return Designates_T (Result_Definition (Acc_Subprg)); - end if; - end if; - - return False; - end Mentions_T; - - -- Start of processing for Check_Anonymous_Access_Components - - begin - if No (Comp_List) then - return; + elsif Has_Inherited_Default_Init_Cond (From_Typ) + or (Parent_To_Derivation + and Present (Get_Pragma + (From_Typ, Pragma_Default_Initial_Condition))) + then + Set_Has_Inherited_Default_Init_Cond (To_Typ); + Inherit_Procedure := True; end if; - Comp := First (Component_Items (Comp_List)); - while Present (Comp) loop - if Nkind (Comp) = N_Component_Declaration - and then Present - (Access_Definition (Component_Definition (Comp))) - and then - Mentions_T (Access_Definition (Component_Definition (Comp))) - then - Comp_Def := Component_Definition (Comp); - Acc_Def := - Access_To_Subprogram_Definition - (Access_Definition (Comp_Def)); - - Build_Incomplete_Type_Declaration; - Anon_Access := Make_Temporary (Loc, 'S'); - - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. - - if Present (Acc_Def) then - if Nkind (Acc_Def) = N_Access_Function_Definition then - Type_Def := - Make_Access_Function_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def), - Result_Definition => Result_Definition (Acc_Def)); - else - Type_Def := - Make_Access_Procedure_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def)); - end if; - - else - Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - 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; - - 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); - - -- If an access to subprogram, create the extra formals - - if Present (Acc_Def) then - Create_Extra_Formals (Designated_Type (Anon_Access)); - - -- If an access to object, preserve entity of designated type, - -- for ASIS use, before rewriting the component definition. - - else - declare - Desig : Entity_Id; - - begin - Desig := Entity (Subtype_Indication (Type_Def)); - - -- If the access definition is to the current record, - -- the visible entity at this point is an incomplete - -- type. Retrieve the full view to simplify ASIS queries - - if Ekind (Desig) = E_Incomplete_Type then - Desig := Full_View (Desig); - end if; - - Set_Entity - (Subtype_Mark (Access_Definition (Comp_Def)), Desig); - end; - end if; - - Rewrite (Comp_Def, - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); - - if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then - Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); - else - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); - end if; - - Set_Is_Local_Anonymous_Access (Anon_Access); - end if; - - Next (Comp); - end loop; - - if Present (Variant_Part (Comp_List)) then - declare - V : Node_Id; - begin - V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - while Present (V) loop - Check_Anonymous_Access_Components - (Typ_Decl, Typ, Prev, Component_List (V)); - Next_Non_Pragma (V); - end loop; - end; + if Inherit_Procedure + and then No (Default_Init_Cond_Procedure (To_Typ)) + then + Set_Default_Init_Cond_Procedure + (To_Typ, Default_Init_Cond_Procedure (From_Typ)); end if; - end Check_Anonymous_Access_Components; + end Propagate_Default_Init_Cond_Attributes; - ---------------------------------- - -- Preanalyze_Assert_Expression -- - ---------------------------------- - - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is - begin - In_Assertion_Expr := In_Assertion_Expr + 1; - Preanalyze_Spec_Expression (N, T); - In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; - - ----------------------------------- - -- Preanalyze_Default_Expression -- - ----------------------------------- - - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expr : constant Boolean := In_Default_Expr; - begin - In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); - In_Default_Expr := Save_In_Default_Expr; - end Preanalyze_Default_Expression; - - -------------------------------- - -- Preanalyze_Spec_Expression -- - -------------------------------- - - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; - begin - In_Spec_Expression := True; - Preanalyze_And_Resolve (N, T); - In_Spec_Expression := Save_In_Spec_Expression; - end Preanalyze_Spec_Expression; - ----------------------------- -- Record_Type_Declaration -- ----------------------------- Index: sem_util.adb =================================================================== --- sem_util.adb (revision 216367) +++ sem_util.adb (working copy) @@ -1247,7 +1247,7 @@ Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Proc_Id, Loc), Parameter_Associations => New_List ( - Make_Type_Conversion (Loc, + Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc), Expression => New_Occurrence_Of (Obj_Id, Loc)))); end Build_Default_Init_Cond_Call; @@ -1442,6 +1442,13 @@ pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Present (Prag)); + -- Nothing to do if the default initial condition procedure was already + -- built. + + if Present (Default_Init_Cond_Procedure (Typ)) then + return; + end if; + Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));

[Ada] Missing inheritance of pragma Default_Initial_Condition

Commit Message

Patch