From 38d0d6c854d9fc64b2c52a73af8db8af247eb0b7 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Fri, 17 Oct 2014 08:34:54 +0000 Subject: [PATCH] sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation of all attributes related to pragma... 2014-10-17 Hristian Kirtchev * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation of all attributes related to pragma Default_Initial_Condition. (Build_Derived_Type): Propagation of all attributes related to pragma Default_Initial_Condition. (Process_Full_View): Account for the case where the full view derives from another private type and propagate the attributes related to pragma Default_Initial_Condition to the private view. (Propagate_Default_Init_Cond_Attributes): New routine. * sem_util.adb: Alphabetize various routines. (Build_Default_Init_Cond_Call): Use an unchecked type conversion when calling the default initial condition procedure of a private type. (Build_Default_Init_Cond_Procedure_Declaration): Prevent the generation of multiple default initial condition procedures. From-SVN: r216370 --- gcc/ada/ChangeLog | 16 + gcc/ada/sem_ch3.adb | 16215 +++++++++++++++++++++-------------------- gcc/ada/sem_util.adb | 9 +- 3 files changed, 8197 insertions(+), 8043 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2661f95196c..df07e44141c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2014-10-17 Hristian Kirtchev + + * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation + of all attributes related to pragma Default_Initial_Condition. + (Build_Derived_Type): Propagation of all attributes related + to pragma Default_Initial_Condition. + (Process_Full_View): Account for the case where the full view derives + from another private type and propagate the attributes related + to pragma Default_Initial_Condition to the private view. + (Propagate_Default_Init_Cond_Attributes): New routine. + * sem_util.adb: Alphabetize various routines. + (Build_Default_Init_Cond_Call): Use an unchecked type conversion + when calling the default initial condition procedure of a private type. + (Build_Default_Init_Cond_Procedure_Declaration): Prevent + the generation of multiple default initial condition procedures. + 2014-10-17 Robert Dewar * prj-conf.adb: Revert previous change. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d1df888579c..08dd79daaf9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -650,6 +650,17 @@ package body Sem_Ch3 is -- 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 @@ package body Sem_Ch3 is 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 @@ package body Sem_Ch3 is 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,10314 +10014,10439 @@ package body Sem_Ch3 is end if; end Check_Aliased_Component_Types; - ---------------------- - -- Check_Completion -- - ---------------------- + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- - procedure Check_Completion (Body_Id : Node_Id := Empty) is - E : Entity_Id; + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Loc : constant Source_Ptr := Sloc (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 Post_Error; - -- Post error message for lack of completion for entity E + 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. - ---------------- - -- Post_Error -- - ---------------- + function Designates_T (Subt : Node_Id) return Boolean; + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type - procedure Post_Error is + 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. - procedure Missing_Body; - -- Output missing body message + -------------------------------------- + -- Build_Incomplete_Type_Declaration -- + -------------------------------------- - ------------------ - -- Missing_Body -- - ------------------ + procedure Build_Incomplete_Type_Declaration is + Decl : Node_Id; + Inc_T : Entity_Id; + H : Entity_Id; - procedure Missing_Body is - begin - -- Spec is in same unit, so we can post on spec + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". - if In_Same_Source_Unit (Body_Id, E) then - Error_Msg_N ("missing body for &", E); + 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))); - -- Spec is in a separate unit, so we have to post on the body + 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. - else - Error_Msg_NE ("missing body for & declared#!", Body_Id, E); + 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; - end Missing_Body; - -- Start of processing for Post_Error + return; - begin - if not Comes_From_Source (E) then + elsif Has_Private_Declaration (Typ) 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. + -- 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. - declare - Var : Entity_Id; + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; - begin - Var := First_Entity (Current_Scope); - while Present (Var) loop - exit when Etype (Var) = E - and then Comes_From_Source (Var); + return; - Next_Entity (Var); - end loop; + -- If there was a previous anonymous access type, the incomplete + -- type declaration will have been created already. - if Present (Var) then - E := Var; - end if; - end; + 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; - end if; - - -- If a generated entity has no completion, then either previous - -- semantic errors have disabled the expansion phase, or else we had - -- missing subunits, or else we are compiling without expansion, - -- or else something is very wrong. - - if not Comes_From_Source (E) then - pragma Assert - (Serious_Errors_Detected > 0 - or else Configurable_Run_Time_Violations > 0 - or else Subunits_Missing - or else not Expander_Active); return; - -- Here for source entity - else - -- Here if no body to post the error message, so we post the error - -- on the declaration that has no completion. This is not really - -- the right place to post it, think about this later ??? + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - if No (Body_Id) then - if Is_Type (E) then - Error_Msg_NE - ("missing full declaration for }", Parent (E), E); - else - Error_Msg_NE ("missing body for &", Parent (E), E); - end if; + -- 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. - -- Package body has no completion for a declaration that appears - -- in the corresponding spec. Post error on the body, with a - -- reference to the non-completed declaration. + H := Current_Entity (Typ); + if H = Typ then + Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); else - Error_Msg_Sloc := Sloc (E); - - if Is_Type (E) then - Error_Msg_NE ("missing full declaration for }!", Body_Id, E); + while Present (H) + and then Homonym (H) /= Typ + loop + H := Homonym (Typ); + end loop; - elsif Is_Overloadable (E) - and then Current_Entity_In_Scope (E) /= E - then - -- It may be that the completion is mistyped and appears as - -- a distinct overloading of the entity. + Set_Homonym (H, Homonym (Typ)); + end if; - declare - Candidate : constant Entity_Id := - Current_Entity_In_Scope (E); - Decl : constant Node_Id := - Unit_Declaration_Node (Candidate); + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, Typ); - begin - if Is_Overloadable (Candidate) - and then Ekind (Candidate) = Ekind (E) - and then Nkind (Decl) = N_Subprogram_Body - and then Acts_As_Spec (Decl) - then - Check_Type_Conformant (Candidate, E); + if Is_Tagged then - else - Missing_Body; - end if; - end; + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. - else - Missing_Body; - end if; + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); + Set_Etype (Class_Wide_Type (Typ), Typ); end if; end if; - end Post_Error; - - -- Start of processing for Check_Completion + end Build_Incomplete_Type_Declaration; - begin - E := First_Entity (Current_Scope); - while Present (E) loop - if Is_Intrinsic_Subprogram (E) then - null; + ------------------ + -- Designates_T -- + ------------------ - -- The following situation requires special handling: a child unit - -- that appears in the context clause of the body of its parent: + function Designates_T (Subt : Node_Id) return Boolean is + Type_Id : constant Name_Id := Chars (Typ); - -- procedure Parent.Child (...); + 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. - -- with Parent.Child; - -- package body Parent is + ------------- + -- Names_T -- + ------------- - -- Here Parent.Child appears as a local entity, but should not be - -- flagged as requiring completion, because it is a compilation - -- unit. + function Names_T (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Identifier then + return Chars (Nam) = Type_Id; - -- Ignore missing completion for a subprogram that does not come from - -- source (including the _Call primitive operation of RAS types, - -- which has to have the flag Comes_From_Source for other purposes): - -- we assume that the expander will provide the missing completion. - -- In case of previous errors, other expansion actions that provide - -- bodies for null procedures with not be invoked, so inhibit message - -- in those cases. - - -- Note that E_Operator is not in the list that follows, because - -- 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 - then - if Has_Completion (E) then - null; - - elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then - null; - - elsif Is_Subprogram (E) - and then (not Comes_From_Source (E) - or else Chars (E) = Name_uCall) - then - null; - - elsif - Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit - then - null; - - elsif Nkind (Parent (E)) = N_Procedure_Specification - and then Null_Present (Parent (E)) - and then Serious_Errors_Detected > 0 - then - null; - - else - Post_Error; - end if; + 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 Is_Entry (E) then - if not Has_Completion (E) and then - (Ekind (Scope (E)) = E_Protected_Object - or else Ekind (Scope (E)) = E_Protected_Type) - then - Post_Error; - end if; + elsif Nkind (Prefix (Nam)) = N_Selected_Component then + return Chars (Selector_Name (Prefix (Nam))) = + Chars (Current_Scope); + else + return False; + end if; - elsif Is_Package_Or_Generic_Package (E) then - if Unit_Requires_Body (E) then - if not Has_Completion (E) - and then Nkind (Parent (Unit_Declaration_Node (E))) /= - N_Compilation_Unit - then - Post_Error; + else + return False; end if; - elsif not Is_Child_Unit (E) then - May_Need_Implicit_Body (E); + else + return False; end if; + end Names_T; - -- A formal incomplete type (Ada 2012) does not require a completion; - -- other incomplete type declarations do. - - elsif Ekind (E) = E_Incomplete_Type - and then No (Underlying_Type (E)) - and then not Is_Generic_Type (E) - then - Post_Error; + -- Start of processing for Designates_T - elsif (Ekind (E) = E_Task_Type or else - Ekind (E) = E_Protected_Type) - and then not Has_Completion (E) - then - Post_Error; + begin + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; - -- A single task declared in the current scope is a constant, verify - -- that the body of its anonymous type is in the same scope. If the - -- task is defined elsewhere, this may be a renaming declaration for - -- which no completion is needed. + -- Reference can be through an expanded name which has not been + -- analyzed yet, and which designates enclosing scopes. - elsif Ekind (E) = E_Constant - and then Ekind (Etype (E)) = E_Task_Type - and then not Has_Completion (Etype (E)) - and then Scope (Etype (E)) = Current_Scope - then - Post_Error; + elsif Nkind (Subt) = N_Selected_Component then + if Names_T (Subt) then + return True; - elsif Ekind (E) = E_Protected_Object - and then not Has_Completion (Etype (E)) - then - Post_Error; + -- 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. - elsif Ekind (E) = E_Record_Type then - if Is_Tagged_Type (E) then - Check_Abstract_Overriding (E); - Check_Conventions (E); + 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; - Check_Aliased_Component_Types (E); + -- A reference to the current type may appear as the prefix of + -- a 'Class attribute. - elsif Ekind (E) = E_Array_Type then - Check_Aliased_Component_Types (E); + 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; - Next_Entity (E); - end loop; - end Check_Completion; + ---------------- + -- Mentions_T -- + ---------------- - ------------------------------------ - -- Check_CPP_Type_Has_No_Defaults -- - ------------------------------------ + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Param_Spec : Node_Id; - procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is - Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); - Clist : Node_Id; - Comp : Node_Id; + Acc_Subprg : constant Node_Id := + Access_To_Subprogram_Definition (Acc_Def); - begin - -- Obtain the component list + begin + if No (Acc_Subprg) then + return Designates_T (Subtype_Mark (Acc_Def)); + end if; - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); - else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; + -- Component is an access_to_subprogram: examine its formals, + -- and result definition in the case of an access_to_function. - -- Check all components to ensure no default expressions + 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; - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have " - & "default expression", Expression (Comp)); + elsif Designates_T (Parameter_Type (Param_Spec)) then + return True; end if; - Next (Comp); + Next (Param_Spec); end loop; - end if; - end Check_CPP_Type_Has_No_Defaults; - - ---------------------------- - -- Check_Delta_Expression -- - ---------------------------- - procedure Check_Delta_Expression (E : Node_Id) is - begin - if not (Is_Real_Type (Etype (E))) then - Wrong_Type (E, Any_Real); + 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; - elsif not Is_OK_Static_Expression (E) then - Flag_Non_Static_Expr - ("non-static expression used for delta value!", E); + return False; + end Mentions_T; - elsif not UR_Is_Positive (Expr_Value_R (E)) then - Error_Msg_N ("delta expression must be positive", E); + -- Start of processing for Check_Anonymous_Access_Components - else + begin + if No (Comp_List) then return; end if; - -- If any of above errors occurred, then replace the incorrect - -- expression by the real 0.1, which should prevent further errors. - - Rewrite (E, - Make_Real_Literal (Sloc (E), Ureal_Tenth)); - Analyze_And_Resolve (E, Standard_Float); - end Check_Delta_Expression; + 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)); - ----------------------------- - -- Check_Digits_Expression -- - ----------------------------- + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); - procedure Check_Digits_Expression (E : Node_Id) is - begin - if not (Is_Integer_Type (Etype (E))) then - Wrong_Type (E, Any_Integer); + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. - elsif not Is_OK_Static_Expression (E) then - Flag_Non_Static_Expr - ("non-static expression used for digits value!", E); + 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; - elsif Expr_Value (E) <= 0 then - Error_Msg_N ("digits value must be greater than zero", E); + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node + (Subtype_Mark (Access_Definition (Comp_Def)))); - else - return; - end if; + Set_Constant_Present + (Type_Def, Constant_Present (Access_Definition (Comp_Def))); + Set_All_Present + (Type_Def, All_Present (Access_Definition (Comp_Def))); + end if; - -- If any of above errors occurred, then replace the incorrect - -- expression by the integer 1, which should prevent further errors. + Set_Null_Exclusion_Present + (Type_Def, + Null_Exclusion_Present (Access_Definition (Comp_Def))); - Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); - Analyze_And_Resolve (E, Standard_Integer); + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); - end Check_Digits_Expression; + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); - -------------------------- - -- Check_Initialization -- - -------------------------- + -- If an access to subprogram, create the extra formals - procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is - begin - -- Special processing for limited types + if Present (Acc_Def) then + Create_Extra_Formals (Designated_Type (Anon_Access)); - if Is_Limited_Type (T) - and then not In_Instance - and then not In_Inlined_Body - then - if not OK_For_Limited_Init (T, Exp) then + -- If an access to object, preserve entity of designated type, + -- for ASIS use, before rewriting the component definition. - -- In GNAT mode, this is just a warning, to allow it to be evilly - -- turned off. Otherwise it is a real error. + else + declare + Desig : Entity_Id; - if GNAT_Mode then - Error_Msg_N - ("??cannot initialize entities of limited type!", Exp); + begin + Desig := Entity (Subtype_Indication (Type_Def)); - elsif Ada_Version < Ada_2005 then + -- 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 - -- The side effect removal machinery may generate illegal Ada - -- code to avoid the usage of access types and 'reference in - -- SPARK mode. Since this is legal code with respect to theorem - -- proving, do not emit the error. + if Ekind (Desig) = E_Incomplete_Type then + Desig := Full_View (Desig); + end if; - if GNATprove_Mode - and then Nkind (Exp) = N_Function_Call - and then Nkind (Parent (Exp)) = N_Object_Declaration - and then not Comes_From_Source - (Defining_Identifier (Parent (Exp))) - then - null; + Set_Entity + (Subtype_Mark (Access_Definition (Comp_Def)), Desig); + end; + end if; - else - Error_Msg_N - ("cannot initialize entities of limited type", Exp); - Explain_Limited_Type (T, Exp); - 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 - -- Specialize error message according to kind of illegal - -- initial expression. - - if Nkind (Exp) = N_Type_Conversion - and then Nkind (Expression (Exp)) = N_Function_Call - then - Error_Msg_N - ("illegal context for call" - & " to function with limited result", Exp); - - else - Error_Msg_N - ("initialization of limited object requires aggregate " - & "or function call", Exp); - end if; + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); end if; - end if; - -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets - -- set unless we can be sure that no range check is required. + Next (Comp); + end loop; - if (GNATprove_Mode or not Expander_Active) - and then Is_Scalar_Type (T) - and then not Is_In_Range (Exp, T, Assume_Valid => True) - then - Set_Do_Range_Check (Exp); + 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_Initialization; + end Check_Anonymous_Access_Components; ---------------------- - -- Check_Interfaces -- + -- Check_Completion -- ---------------------- - procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is - Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + procedure Check_Completion (Body_Id : Node_Id := Empty) is + E : Entity_Id; - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; - Parent_Node : Node_Id; + procedure Post_Error; + -- Post error message for lack of completion for entity E - Is_Task : Boolean := False; - -- Set True if parent type or any progenitor is a task interface + ---------------- + -- Post_Error -- + ---------------- - Is_Protected : Boolean := False; - -- Set True if parent type or any progenitor is a protected interface + procedure Post_Error is - 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. + procedure Missing_Body; + -- Output missing body message - ------------------ - -- Check_Ifaces -- - ------------------ + ------------------ + -- Missing_Body -- + ------------------ - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is - Iface_Id : constant Entity_Id := - Defining_Identifier (Parent (Iface_Def)); - Type_Def : Node_Id; + procedure Missing_Body is + begin + -- Spec is in same unit, so we can post on spec - begin - if Nkind (N) = N_Private_Extension_Declaration then - Type_Def := N; - else - Type_Def := Type_Definition (N); - end if; + if In_Same_Source_Unit (Body_Id, E) then + Error_Msg_N ("missing body for &", E); - if Is_Task_Interface (Iface_Id) then - Is_Task := True; + -- Spec is in a separate unit, so we have to post on the body - elsif Is_Protected_Interface (Iface_Id) then - Is_Protected := True; - end if; + else + Error_Msg_NE ("missing body for & declared#!", Body_Id, E); + end if; + end Missing_Body; - if Is_Synchronized_Interface (Iface_Id) then + -- Start of processing for Post_Error - -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private - -- extension derived from a synchronized interface must explicitly - -- be declared synchronized, because the full view will be a - -- synchronized type. + begin + if not Comes_From_Source (E) then - if Nkind (N) = N_Private_Extension_Declaration then - if not Synchronized_Present (N) then - Error_Msg_NE - ("private extension of& must be explicitly synchronized", - N, Iface_Id); - end if; + if Ekind_In (E, E_Task_Type, E_Protected_Type) then - -- However, by 3.9.4(16/2), a full type that is a record extension - -- is never allowed to derive from a synchronized interface (note - -- that interfaces must be excluded from this check, because those - -- are represented by derived type definitions in some cases). + -- It may be an anonymous protected type created for a + -- single variable. Post error on variable, if present. - 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); - end if; - end if; + declare + Var : Entity_Id; - -- Check that the characteristics of the progenitor are compatible - -- with the explicit qualifier in the declaration. - -- The check only applies to qualifiers that come from source. - -- Limited_Present also appears in the declaration of corresponding - -- records, and the check does not apply to them. + begin + Var := First_Entity (Current_Scope); + while Present (Var) loop + exit when Etype (Var) = E + and then Comes_From_Source (Var); - if Limited_Present (Type_Def) - and then not - Is_Concurrent_Record_Type (Defining_Identifier (N)) - then - if Is_Limited_Interface (Parent_Type) - and then not Is_Limited_Interface (Iface_Id) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); + Next_Entity (Var); + end loop; - elsif - (Task_Present (Iface_Def) - or else Protected_Present (Iface_Def) - or else Synchronized_Present (Iface_Def)) - and then Nkind (N) /= N_Private_Extension_Declaration - and then not Error_Posted (N) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); + if Present (Var) then + E := Var; + end if; + end; end if; + end if; - -- Protected interfaces can only inherit from limited, synchronized - -- or protected interfaces. + -- If a generated entity has no completion, then either previous + -- semantic errors have disabled the expansion phase, or else we had + -- missing subunits, or else we are compiling without expansion, + -- or else something is very wrong. - elsif Nkind (N) = N_Full_Type_Declaration - and then Protected_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; + if not Comes_From_Source (E) then + pragma Assert + (Serious_Errors_Detected > 0 + or else Configurable_Run_Time_Violations > 0 + or else Subunits_Missing + or else not Expander_Active); + return; - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); + -- Here for source entity - else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; + else + -- Here if no body to post the error message, so we post the error + -- on the declaration that has no completion. This is not really + -- the right place to post it, think about this later ??? - -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from - -- limited and synchronized. + if No (Body_Id) then + if Is_Type (E) then + Error_Msg_NE + ("missing full declaration for }", Parent (E), E); + else + Error_Msg_NE ("missing body for &", Parent (E), E); + end if; - elsif Synchronized_Present (Type_Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; + -- Package body has no completion for a declaration that appears + -- in the corresponding spec. Post error on the body, with a + -- reference to the non-completed declaration. - 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); + else + Error_Msg_Sloc := Sloc (E); - 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); + if Is_Type (E) then + Error_Msg_NE ("missing full declaration for }!", Body_Id, E); - elsif not Is_Limited_Interface (Iface_Id) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; + elsif Is_Overloadable (E) + and then Current_Entity_In_Scope (E) /= E + then + -- It may be that the completion is mistyped and appears as + -- a distinct overloading of the entity. - -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, - -- synchronized or task interfaces. + declare + Candidate : constant Entity_Id := + Current_Entity_In_Scope (E); + Decl : constant Node_Id := + Unit_Declaration_Node (Candidate); - elsif Nkind (N) = N_Full_Type_Declaration - and then Task_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Task_Present (Iface_Def) - then - null; + begin + if Is_Overloadable (Candidate) + and then Ekind (Candidate) = Ekind (E) + and then Nkind (Decl) = N_Subprogram_Body + and then Acts_As_Spec (Decl) + then + Check_Type_Conformant (Candidate, E); - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " protected interface", Error_Node); + else + Missing_Body; + end if; + end; - else - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " non-limited interface", Error_Node); + else + Missing_Body; + end if; end if; end if; - end Check_Ifaces; + end Post_Error; - -- Start of processing for Check_Interfaces + -- Start of processing for Check_Completion begin - if Is_Interface (Parent_Type) then - if Is_Task_Interface (Parent_Type) then - Is_Task := True; + E := First_Entity (Current_Scope); + while Present (E) loop + if Is_Intrinsic_Subprogram (E) then + null; - elsif Is_Protected_Interface (Parent_Type) then - Is_Protected := True; - end if; - end if; + -- The following situation requires special handling: a child unit + -- that appears in the context clause of the body of its parent: - if Nkind (N) = N_Private_Extension_Declaration then + -- procedure Parent.Child (...); - -- Check that progenitors are compatible with declaration + -- with Parent.Child; + -- package body Parent is - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + -- Here Parent.Child appears as a local entity, but should not be + -- flagged as requiring completion, because it is a compilation + -- unit. - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); + -- Ignore missing completion for a subprogram that does not come from + -- source (including the _Call primitive operation of RAS types, + -- which has to have the flag Comes_From_Source for other purposes): + -- we assume that the expander will provide the missing completion. + -- In case of previous errors, other expansion actions that provide + -- bodies for null procedures with not be invoked, so inhibit message + -- in those cases. - if not Is_Interface (Iface_Typ) then - Diagnose_Interface (Iface, Iface_Typ); + -- Note that E_Operator is not in the list that follows, because + -- this kind is reserved for predefined operators, that are + -- intrinsic and do not need completion. + + elsif Ekind_In (E, E_Function, + E_Procedure, + E_Generic_Function, + E_Generic_Procedure) + then + if Has_Completion (E) then + null; + + elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then + null; + + elsif Is_Subprogram (E) + and then (not Comes_From_Source (E) + or else Chars (E) = Name_uCall) + then + null; + + elsif + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + null; + + elsif Nkind (Parent (E)) = N_Procedure_Specification + and then Null_Present (Parent (E)) + and then Serious_Errors_Detected > 0 + then + null; else - Check_Ifaces (Iface_Def, Iface); + Post_Error; end if; - Next (Iface); - end loop; + elsif Is_Entry (E) then + if not Has_Completion (E) and then + (Ekind (Scope (E)) = E_Protected_Object + or else Ekind (Scope (E)) = E_Protected_Type) + then + Post_Error; + end if; - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; + elsif Is_Package_Or_Generic_Package (E) then + if Unit_Requires_Body (E) then + if not Has_Completion (E) + and then Nkind (Parent (Unit_Declaration_Node (E))) /= + N_Compilation_Unit + then + Post_Error; + end if; - return; - end if; + elsif not Is_Child_Unit (E) then + May_Need_Implicit_Body (E); + end if; - -- Full type declaration of derived type. - -- Check compatibility with parent if it is interface type + -- A formal incomplete type (Ada 2012) does not require a completion; + -- other incomplete type declarations do. - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then Is_Interface (Parent_Type) - then - Parent_Node := Parent (Parent_Type); + elsif Ekind (E) = E_Incomplete_Type + and then No (Underlying_Type (E)) + and then not Is_Generic_Type (E) + then + Post_Error; - -- More detailed checks for interface varieties + elsif Ekind_In (E, E_Task_Type, E_Protected_Type) + and then not Has_Completion (E) + then + Post_Error; - Check_Ifaces - (Iface_Def => Type_Definition (Parent_Node), - Error_Node => Subtype_Indication (Type_Definition (N))); - end if; + -- A single task declared in the current scope is a constant, verify + -- that the body of its anonymous type is in the same scope. If the + -- task is defined elsewhere, this may be a renaming declaration for + -- which no completion is needed. - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + elsif Ekind (E) = E_Constant + and then Ekind (Etype (E)) = E_Task_Type + and then not Has_Completion (Etype (E)) + and then Scope (Etype (E)) = Current_Scope + then + Post_Error; - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); + elsif Ekind (E) = E_Protected_Object + and then not Has_Completion (Etype (E)) + then + Post_Error; - if not Is_Interface (Iface_Typ) then - Diagnose_Interface (Iface, Iface_Typ); + elsif Ekind (E) = E_Record_Type then + if Is_Tagged_Type (E) then + Check_Abstract_Overriding (E); + Check_Conventions (E); + end if; - else - -- "The declaration of a specific descendant of an interface - -- type freezes the interface type" RM 13.14 + Check_Aliased_Component_Types (E); + + elsif Ekind (E) = E_Array_Type then + Check_Aliased_Component_Types (E); - Freeze_Before (N, Iface_Typ); - Check_Ifaces (Iface_Def, Error_Node => Iface); end if; - Next (Iface); + Next_Entity (E); end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - end Check_Interfaces; + end Check_Completion; ------------------------------------ - -- Check_Or_Process_Discriminants -- + -- Check_CPP_Type_Has_No_Defaults -- ------------------------------------ - -- If an incomplete or private type declaration was already given for the - -- type, the discriminants may have already been processed if they were - -- present on the incomplete declaration. In this case a full conformance - -- check has been performed in Find_Type_Name, and we then recheck here - -- some properties that can't be checked on the partial view alone. - -- Otherwise we call Process_Discriminants. + procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is + Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); + Clist : Node_Id; + Comp : Node_Id; - procedure Check_Or_Process_Discriminants - (N : Node_Id; - T : Entity_Id; - Prev : Entity_Id := Empty) - is begin - if Has_Discriminants (T) then - - -- Discriminants are already set on T if they were already present - -- on the partial view. Make them visible to component declarations. - - declare - D : Entity_Id; - -- Discriminant on T (full view) referencing expr on partial view - - Prev_D : Entity_Id; - -- 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 - -- conformance with partial view), only used here to post error - -- message. - - begin - D := First_Discriminant (T); - New_D := First (Discriminant_Specifications (N)); - while Present (D) loop - Prev_D := Current_Entity (D); - Set_Current_Entity (D); - Set_Is_Immediately_Visible (D); - Set_Homonym (D, Prev_D); - - -- Handle the case where there is an untagged partial view and - -- the full view is tagged: must disallow discriminants with - -- defaults, unless compiling for Ada 2012, which allows a - -- limited tagged type to have defaulted discriminants (see - -- AI05-0214). However, suppress error here if it was already - -- reported on the default expression of the partial view. - - if Is_Tagged_Type (T) - and then Present (Expression (Parent (D))) - and then (not Is_Limited_Type (Current_Scope) - or else Ada_Version < Ada_2012) - and then not Error_Posted (Expression (Parent (D))) - then - if Ada_Version >= Ada_2012 then - Error_Msg_N - ("discriminants of nonlimited tagged type cannot have" - & " defaults", - Expression (New_D)); - else - Error_Msg_N - ("discriminants of tagged type cannot have defaults", - Expression (New_D)); - end if; - end if; - - -- Ada 2005 (AI-230): Access discriminant allowed in - -- non-limited record types. - - if Ada_Version < Ada_2005 then + -- Obtain the component list - -- This restriction gets applied to the full type here. It - -- has already been applied earlier to the partial view. + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; - Check_Access_Discriminant_Requires_Limited (Parent (D), N); - end if; + -- Check all components to ensure no default expressions - Next_Discriminant (D); - Next (New_D); - end loop; - end; + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have " + & "default expression", Expression (Comp)); + end if; - elsif Present (Discriminant_Specifications (N)) then - Process_Discriminants (N, Prev); + Next (Comp); + end loop; end if; - end Check_Or_Process_Discriminants; + end Check_CPP_Type_Has_No_Defaults; - ---------------------- - -- Check_Real_Bound -- - ---------------------- + ---------------------------- + -- Check_Delta_Expression -- + ---------------------------- - procedure Check_Real_Bound (Bound : Node_Id) is + procedure Check_Delta_Expression (E : Node_Id) is begin - if not Is_Real_Type (Etype (Bound)) then - Error_Msg_N - ("bound in real type definition must be of real type", Bound); + if not (Is_Real_Type (Etype (E))) then + Wrong_Type (E, Any_Real); - elsif not Is_OK_Static_Expression (Bound) then + elsif not Is_OK_Static_Expression (E) then Flag_Non_Static_Expr - ("non-static expression used for real type bound!", Bound); + ("non-static expression used for delta value!", E); + + elsif not UR_Is_Positive (Expr_Value_R (E)) then + Error_Msg_N ("delta expression must be positive", E); else return; end if; - Rewrite - (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); - Analyze (Bound); - Resolve (Bound, Standard_Float); - end Check_Real_Bound; + -- If any of above errors occurred, then replace the incorrect + -- expression by the real 0.1, which should prevent further errors. - ------------------------------ - -- Complete_Private_Subtype -- - ------------------------------ + Rewrite (E, + Make_Real_Literal (Sloc (E), Ureal_Tenth)); + Analyze_And_Resolve (E, Standard_Float); + end Check_Delta_Expression; - procedure Complete_Private_Subtype - (Priv : Entity_Id; - Full : Entity_Id; - Full_Base : Entity_Id; - Related_Nod : Node_Id) - is - Save_Next_Entity : Entity_Id; - Save_Homonym : Entity_Id; + ----------------------------- + -- Check_Digits_Expression -- + ----------------------------- + procedure Check_Digits_Expression (E : Node_Id) is 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. - - -- 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); - Save_Homonym := Homonym (Priv); + if not (Is_Integer_Type (Etype (E))) then + Wrong_Type (E, Any_Integer); - case Ekind (Full_Base) is - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - Private_Kind | - Task_Kind | - Protected_Kind => - Copy_Node (Priv, Full); + elsif not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static expression used for digits value!", E); - Set_Has_Discriminants - (Full, Has_Discriminants (Full_Base)); - Set_Has_Unknown_Discriminants - (Full, Has_Unknown_Discriminants (Full_Base)); - Set_First_Entity (Full, First_Entity (Full_Base)); - Set_Last_Entity (Full, Last_Entity (Full_Base)); + elsif Expr_Value (E) <= 0 then + Error_Msg_N ("digits value must be greater than zero", E); - -- If the underlying base type is constrained, we know that the - -- full view of the subtype is constrained as well (the converse - -- is not necessarily true). + else + return; + end if; - if Is_Constrained (Full_Base) then - Set_Is_Constrained (Full); - end if; + -- If any of above errors occurred, then replace the incorrect + -- expression by the integer 1, which should prevent further errors. - when others => - Copy_Node (Full_Base, Full); + Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); + Analyze_And_Resolve (E, Standard_Integer); - Set_Chars (Full, Chars (Priv)); - Conditional_Delay (Full, Priv); - Set_Sloc (Full, Sloc (Priv)); - end case; + end Check_Digits_Expression; - Set_Next_Entity (Full, Save_Next_Entity); - Set_Homonym (Full, Save_Homonym); - Set_Associated_Node_For_Itype (Full, Related_Nod); + -------------------------- + -- Check_Initialization -- + -------------------------- - -- Set common attributes for all subtypes: kind, convention, etc. + procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is + begin + -- Special processing for limited types - Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); - Set_Convention (Full, Convention (Full_Base)); + if Is_Limited_Type (T) + and then not In_Instance + and then not In_Inlined_Body + then + if not OK_For_Limited_Init (T, Exp) then - -- 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: + -- In GNAT mode, this is just a warning, to allow it to be evilly + -- turned off. Otherwise it is a real error. - -- Set_Etype (Full, Full_Base); + if GNAT_Mode then + Error_Msg_N + ("??cannot initialize entities of limited type!", Exp); - -- then we get inconsistencies in the front-end (confusion between - -- views). Several outstanding bugs are related to this ??? + elsif Ada_Version < Ada_2005 then - Set_Is_First_Subtype (Full, False); - Set_Scope (Full, Scope (Priv)); - Set_Size_Info (Full, Full_Base); - Set_RM_Size (Full, RM_Size (Full_Base)); - Set_Is_Itype (Full); + -- The side effect removal machinery may generate illegal Ada + -- code to avoid the usage of access types and 'reference in + -- SPARK mode. Since this is legal code with respect to theorem + -- proving, do not emit the error. - -- A subtype of a private-type-without-discriminants, whose full-view - -- has discriminants with default expressions, is not constrained. + if GNATprove_Mode + and then Nkind (Exp) = N_Function_Call + and then Nkind (Parent (Exp)) = N_Object_Declaration + and then not Comes_From_Source + (Defining_Identifier (Parent (Exp))) + then + null; - if not Has_Discriminants (Priv) then - Set_Is_Constrained (Full, Is_Constrained (Full_Base)); + else + Error_Msg_N + ("cannot initialize entities of limited type", Exp); + Explain_Limited_Type (T, Exp); + end if; - if Has_Discriminants (Full_Base) then - Set_Discriminant_Constraint - (Full, Discriminant_Constraint (Full_Base)); + else + -- Specialize error message according to kind of illegal + -- initial expression. - -- The partial view may have been indefinite, the full view - -- might not be. + if Nkind (Exp) = N_Type_Conversion + and then Nkind (Expression (Exp)) = N_Function_Call + then + Error_Msg_N + ("illegal context for call" + & " to function with limited result", Exp); - Set_Has_Unknown_Discriminants - (Full, Has_Unknown_Discriminants (Full_Base)); + else + Error_Msg_N + ("initialization of limited object requires aggregate " + & "or function call", Exp); + end if; + end if; end if; end if; - Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); - Set_Depends_On_Private (Full, Has_Private_Component (Full)); + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets + -- set unless we can be sure that no range check is required. - -- Freeze the private subtype entity if its parent is delayed, and not - -- already frozen. We skip this processing if the type is an anonymous - -- subtype of a record component, or is the corresponding record of a - -- protected type, since ??? - - if not Is_Type (Scope (Full)) then - Set_Has_Delayed_Freeze (Full, - Has_Delayed_Freeze (Full_Base) - and then (not Is_Frozen (Full_Base))); - end if; - - Set_Freeze_Node (Full, Empty); - Set_Is_Frozen (Full, False); - Set_Full_View (Priv, Full); - - if Has_Discriminants (Full) then - Set_Stored_Constraint_From_Discriminant_Constraint (Full); - Set_Stored_Constraint (Priv, Stored_Constraint (Full)); - - if Has_Unknown_Discriminants (Full) then - Set_Discriminant_Constraint (Full, No_Elist); - end if; + if (GNATprove_Mode or not Expander_Active) + and then Is_Scalar_Type (T) + and then not Is_In_Range (Exp, T, Assume_Valid => True) + then + Set_Do_Range_Check (Exp); end if; + end Check_Initialization; - if Ekind (Full_Base) = E_Record_Type - and then Has_Discriminants (Full_Base) - and then Has_Discriminants (Priv) -- might not, if errors - and then not Has_Unknown_Discriminants (Priv) - and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) - then - Create_Constrained_Components - (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); + ---------------------- + -- Check_Interfaces -- + ---------------------- - -- If the full base is itself derived from private, build a congruent - -- subtype of its underlying type, for use by the back end. For a - -- constrained record component, the declaration cannot be placed on - -- the component list, but it must nevertheless be built an analyzed, to - -- supply enough information for Gigi to compute the size of component. + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); - elsif Ekind (Full_Base) in Private_Kind - and then Is_Derived_Type (Full_Base) - and then Has_Discriminants (Full_Base) - and then (Ekind (Current_Scope) /= E_Record_Subtype) - then - if not Is_Itype (Priv) - and then - Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication - then - Build_Underlying_Full_View - (Parent (Priv), Full, Etype (Full_Base)); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; - elsif Nkind (Related_Nod) = N_Component_Declaration then - Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); - end if; + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface - elsif Is_Record_Type (Full_Base) then + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface - -- Show Full is simply a renaming of Full_Base + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Check that a progenitor is compatible with declaration. If an error + -- message is output, it is posted on Error_Node. - Set_Cloned_Subtype (Full, Full_Base); - end if; + ------------------ + -- Check_Ifaces -- + ------------------ - -- It is unsafe to share the bounds of a scalar type, because the Itype - -- is elaborated on demand, and if a bound is non-static then different - -- orders of elaboration in different units will lead to different - -- external symbols. + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + Iface_Id : constant Entity_Id := + Defining_Identifier (Parent (Iface_Def)); + Type_Def : Node_Id; - if Is_Scalar_Type (Full_Base) then - Set_Scalar_Range (Full, - Make_Range (Sloc (Related_Nod), - Low_Bound => - Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), - High_Bound => - Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); + begin + if Nkind (N) = N_Private_Extension_Declaration then + Type_Def := N; + else + Type_Def := Type_Definition (N); + end if; - -- This completion inherits the bounds of the full parent, but if - -- the parent is an unconstrained floating point type, so is the - -- completion. + if Is_Task_Interface (Iface_Id) then + Is_Task := True; - if Is_Floating_Point_Type (Full_Base) then - Set_Includes_Infinities - (Scalar_Range (Full), Has_Infinities (Full_Base)); + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; end if; - end if; - -- ??? It seems that a lot of fields are missing that should be copied - -- from Full_Base to Full. Here are some that are introduced in a - -- non-disruptive way but a cleanup is necessary. + if Is_Synchronized_Interface (Iface_Id) then - if Is_Tagged_Type (Full_Base) then - Set_Is_Tagged_Type (Full); - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Full_Base)); + -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private + -- extension derived from a synchronized interface must explicitly + -- be declared synchronized, because the full view will be a + -- synchronized type. - -- Inherit class_wide type of full_base in case the partial view was - -- not tagged. Otherwise it has already been created when the private - -- subtype was analyzed. + if Nkind (N) = N_Private_Extension_Declaration then + if not Synchronized_Present (N) then + Error_Msg_NE + ("private extension of& must be explicitly synchronized", + N, Iface_Id); + end if; - if No (Class_Wide_Type (Full)) then - Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + -- However, by 3.9.4(16/2), a full type that is a record extension + -- is never allowed to derive from a synchronized interface (note + -- that interfaces must be excluded from this check, because those + -- are represented by derived type definitions in some cases). + + 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); + end if; end if; - -- If this is a subtype of a protected or task type, constrain its - -- corresponding record, unless this is a subtype without constraints, - -- i.e. a simple renaming as with an actual subtype in an instance. + -- Check that the characteristics of the progenitor are compatible + -- with the explicit qualifier in the declaration. + -- The check only applies to qualifiers that come from source. + -- Limited_Present also appears in the declaration of corresponding + -- records, and the check does not apply to them. - elsif Is_Concurrent_Type (Full_Base) then - if Has_Discriminants (Full) - and then Present (Corresponding_Record_Type (Full_Base)) - and then - not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) + if Limited_Present (Type_Def) + and then not + Is_Concurrent_Record_Type (Defining_Identifier (N)) then - Set_Corresponding_Record_Type (Full, - Constrain_Corresponding_Record - (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); + if Is_Limited_Interface (Parent_Type) + and then not Is_Limited_Interface (Iface_Id) + then + Error_Msg_NE + ("progenitor & must be limited interface", + Error_Node, Iface_Id); - else - Set_Corresponding_Record_Type (Full, - Corresponding_Record_Type (Full_Base)); - end if; - end if; + elsif + (Task_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def)) + and then Nkind (N) /= N_Private_Extension_Declaration + and then not Error_Posted (N) + then + Error_Msg_NE + ("progenitor & must be limited interface", + Error_Node, Iface_Id); + end if; - -- Link rep item chain, and also setting of Has_Predicates from private - -- subtype to full subtype, since we will need these on the full subtype - -- to create the predicate function. Note that the full subtype may - -- already have rep items, inherited from the full view of the base - -- type, so we must be sure not to overwrite these entries. + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. - declare - Append : Boolean; - Item : Node_Id; - Next_Item : Node_Id; + elsif Nkind (N) = N_Full_Type_Declaration + and then Protected_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; - begin - Item := First_Rep_Item (Full); + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from task interface", Error_Node); - -- If no existing rep items on full type, we can just link directly - -- to the list of items on the private type. + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from non-limited interface", Error_Node); + end if; - if No (Item) then - Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. - -- Otherwise, search to the end of items currently linked to the full - -- subtype and append the private items to the end. However, if Priv - -- and Full already have the same list of rep items, then the append - -- is not done, as that would create a circularity. + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; - elsif Item /= First_Rep_Item (Priv) then - Append := True; + 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); - loop - Next_Item := Next_Rep_Item (Item); - exit when No (Next_Item); - Item := Next_Item; + 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); - -- If the private view has aspect specifications, the full view - -- inherits them. Since these aspects may already have been - -- attached to the full view during derivation, do not append - -- them if already present. + elsif not Is_Limited_Interface (Iface_Id) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from non-limited interface", Error_Node); + end if; - if Item = First_Rep_Item (Priv) then - Append := False; - exit; - end if; - end loop; + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. - -- And link the private type items at the end of the chain + elsif Nkind (N) = N_Full_Type_Declaration + and then Task_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; - if Append then - Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "non-limited interface", Error_Node); end if; end if; - end; + end Check_Ifaces; - -- Make sure Has_Predicates is set on full type if it is set on the - -- private type. Note that it may already be set on the full type and - -- if so, we don't want to unset it. + -- Start of processing for Check_Interfaces - if Has_Predicates (Priv) then - Set_Has_Predicates (Full); - end if; - end Complete_Private_Subtype; + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; - ---------------------------- - -- Constant_Redeclaration -- - ---------------------------- + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; + end if; + end if; - procedure Constant_Redeclaration - (Id : Entity_Id; - N : Node_Id; - T : out Entity_Id) - is - Prev : constant Entity_Id := Current_Entity_In_Scope (Id); - Obj_Def : constant Node_Id := Object_Definition (N); - New_T : Entity_Id; + if Nkind (N) = N_Private_Extension_Declaration then - 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. + -- Check that progenitors are compatible with declaration - 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, - -- through a default value of some record subcomponent. This is normally - -- detected when generating init procs, but requires this additional - -- mechanism when expansion is disabled. + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - ---------------------------------------- - -- Check_Possible_Deferred_Completion -- - ---------------------------------------- + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); - 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_Temporary (Loc, 'S'); - Decl : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => - Relocate_Node (Curr_Obj_Def)); + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + else + Check_Ifaces (Iface_Def, Iface); + end if; - begin - Insert_Before_And_Analyze (N, Decl); - Set_Etype (Id, Def_Id); + Next (Iface); + end loop; - 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; + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); end if; - end Check_Possible_Deferred_Completion; - - --------------------------------- - -- Check_Recursive_Declaration -- - --------------------------------- - - procedure Check_Recursive_Declaration (Typ : Entity_Id) is - Comp : Entity_Id; - begin - if Is_Record_Type (Typ) then - Comp := First_Component (Typ); - while Present (Comp) loop - if Comes_From_Source (Comp) then - if Present (Expression (Parent (Comp))) - and then Is_Entity_Name (Expression (Parent (Comp))) - and then Entity (Expression (Parent (Comp))) = Prev - then - Error_Msg_Sloc := Sloc (Parent (Comp)); - Error_Msg_NE - ("illegal circularity with declaration for&#", - N, Comp); - return; + return; + end if; - elsif Is_Record_Type (Etype (Comp)) then - Check_Recursive_Declaration (Etype (Comp)); - end if; - end if; + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type - Next_Component (Comp); - end loop; - end if; - end Check_Recursive_Declaration; + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); - -- Start of processing for Constant_Redeclaration + -- More detailed checks for interface varieties - begin - if Nkind (Parent (Prev)) = N_Object_Declaration then - if Nkind (Object_Definition - (Parent (Prev))) = N_Subtype_Indication - then - -- Find type of new declaration. The constraints of the two - -- views must match statically, but there is no point in - -- creating an itype for the full view. + Check_Ifaces + (Iface_Def => Type_Definition (Parent_Node), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; - if Nkind (Obj_Def) = N_Subtype_Indication then - Find_Type (Subtype_Mark (Obj_Def)); - New_T := Entity (Subtype_Mark (Obj_Def)); + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - else - Find_Type (Obj_Def); - New_T := Entity (Obj_Def); - end if; + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); - T := Etype (Prev); + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); else - -- The full view may impose a constraint, even if the partial - -- view does not, so construct the subtype. + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 - New_T := Find_Type_Of_Object (Obj_Def, N); - T := New_T; + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); end if; - else - -- Current declaration is illegal, diagnosed below in Enter_Name + Next (Iface); + end loop; - T := Empty; - New_T := Any_Type; + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); end if; + end Check_Interfaces; - -- If previous full declaration or a renaming declaration exists, or if - -- a homograph is present, let Enter_Name handle it, either with an - -- error or with the removal of an overridden implicit subprogram. - -- The previous one is a full declaration if it has an expression - -- (which in the case of an aggregate is indicated by the Init flag). - - if Ekind (Prev) /= E_Constant - or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration - or else Present (Expression (Parent (Prev))) - or else Has_Init_Expression (Parent (Prev)) - or else Present (Full_View (Prev)) - then - Enter_Name (Id); - - -- Verify that types of both declarations match, or else that both types - -- are anonymous access types whose designated subtypes statically match - -- (as allowed in Ada 2005 by AI-385). + ------------------------------------ + -- Check_Or_Process_Discriminants -- + ------------------------------------ - elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) - and then - (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type - or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type - or else Is_Access_Constant (Etype (New_T)) /= - Is_Access_Constant (Etype (Prev)) - or else Can_Never_Be_Null (Etype (New_T)) /= - Can_Never_Be_Null (Etype (Prev)) - or else Null_Exclusion_Present (Parent (Prev)) /= - Null_Exclusion_Present (Parent (Id)) - or else not Subtypes_Statically_Match - (Designated_Type (Etype (Prev)), - Designated_Type (Etype (New_T)))) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("type does not match declaration#", N); - Set_Full_View (Prev, Id); - Set_Etype (Id, Any_Type); + -- If an incomplete or private type declaration was already given for the + -- type, the discriminants may have already been processed if they were + -- present on the incomplete declaration. In this case a full conformance + -- check has been performed in Find_Type_Name, and we then recheck here + -- some properties that can't be checked on the partial view alone. + -- Otherwise we call Process_Discriminants. - elsif - Null_Exclusion_Present (Parent (Prev)) - and then not Null_Exclusion_Present (N) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("null-exclusion does not match declaration#", N); - Set_Full_View (Prev, Id); - Set_Etype (Id, Any_Type); + procedure Check_Or_Process_Discriminants + (N : Node_Id; + T : Entity_Id; + Prev : Entity_Id := Empty) + is + begin + if Has_Discriminants (T) then - -- If so, process the full constant declaration + -- Discriminants are already set on T if they were already present + -- on the partial view. Make them visible to component declarations. - 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. + declare + D : Entity_Id; + -- Discriminant on T (full view) referencing expr on partial view - Check_Possible_Deferred_Completion - (Prev_Id => Prev, - Prev_Obj_Def => Object_Definition (Parent (Prev)), - Curr_Obj_Def => Obj_Def); + Prev_D : Entity_Id; + -- Entity of corresponding discriminant on partial view - Set_Full_View (Prev, Id); - Set_Is_Public (Id, Is_Public (Prev)); - Set_Is_Internal (Id); - Append_Entity (Id, Current_Scope); + New_D : Node_Id; + -- 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. - -- Check ALIASED present if present before (RM 7.4(7)) + begin + D := First_Discriminant (T); + New_D := First (Discriminant_Specifications (N)); + while Present (D) loop + Prev_D := Current_Entity (D); + Set_Current_Entity (D); + Set_Is_Immediately_Visible (D); + Set_Homonym (D, Prev_D); - if Is_Aliased (Prev) - and then not Aliased_Present (N) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("ALIASED required (see declaration#)", N); - end if; + -- Handle the case where there is an untagged partial view and + -- the full view is tagged: must disallow discriminants with + -- defaults, unless compiling for Ada 2012, which allows a + -- limited tagged type to have defaulted discriminants (see + -- AI05-0214). However, suppress error here if it was already + -- reported on the default expression of the partial view. - -- Check that placement is in private part and that the incomplete - -- declaration appeared in the visible part. + if Is_Tagged_Type (T) + and then Present (Expression (Parent (D))) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then not Error_Posted (Expression (Parent (D))) + then + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have " + & "defaults", + Expression (New_D)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (New_D)); + end if; + end if; - if Ekind (Current_Scope) = E_Package - and then not In_Private_Part (Current_Scope) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N - ("full constant for declaration#" - & " must be in private part", N); + -- Ada 2005 (AI-230): Access discriminant allowed in + -- non-limited record types. - elsif Ekind (Current_Scope) = E_Package - and then - List_Containing (Parent (Prev)) /= - Visible_Declarations (Package_Specification (Current_Scope)) - then - Error_Msg_N - ("deferred constant must be declared in visible part", - Parent (Prev)); - end if; + if Ada_Version < Ada_2005 then - if Is_Access_Type (T) - and then Nkind (Expression (N)) = N_Allocator - then - Check_Recursive_Declaration (Designated_Type (T)); - end if; + -- This restriction gets applied to the full type here. It + -- has already been applied earlier to the partial view. - -- A deferred constant is a visible entity. If type has invariants, - -- verify that the initial value satisfies them. + Check_Access_Discriminant_Requires_Limited (Parent (D), N); + end if; - if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then - Insert_After (N, - Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); - end if; + Next_Discriminant (D); + Next (New_D); + end loop; + end; + + elsif Present (Discriminant_Specifications (N)) then + Process_Discriminants (N, Prev); end if; - end Constant_Redeclaration; + end Check_Or_Process_Discriminants; ---------------------- - -- Constrain_Access -- + -- Check_Real_Bound -- ---------------------- - procedure Constrain_Access - (Def_Id : in out Entity_Id; - S : Node_Id; - Related_Nod : Node_Id) - is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - Desig_Type : constant Entity_Id := Designated_Type (T); - Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); - Constraint_OK : Boolean := True; - + procedure Check_Real_Bound (Bound : Node_Id) is begin - if Is_Array_Type (Desig_Type) then - Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); + if not Is_Real_Type (Etype (Bound)) then + Error_Msg_N + ("bound in real type definition must be of real type", Bound); - elsif (Is_Record_Type (Desig_Type) - or else Is_Incomplete_Or_Private_Type (Desig_Type)) - and then not Is_Constrained (Desig_Type) - then - -- ??? The following code is a temporary bypass to ignore a - -- discriminant constraint on access type if it is constraining - -- the current record. Avoid creating the implicit subtype of the - -- record we are currently compiling since right now, we cannot - -- handle these. For now, just return the access type itself. + elsif not Is_OK_Static_Expression (Bound) then + Flag_Non_Static_Expr + ("non-static expression used for real type bound!", Bound); - if Desig_Type = Current_Scope - and then No (Def_Id) - then - Set_Ekind (Desig_Subtype, E_Record_Subtype); - Def_Id := Entity (Subtype_Mark (S)); + else + return; + end if; - -- This call added to ensure that the constraint is analyzed - -- (needed for a B test). Note that we still return early from - -- this procedure to avoid recursive processing. ??? + Rewrite + (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); + Analyze (Bound); + Resolve (Bound, Standard_Float); + end Check_Real_Bound; - Constrain_Discriminated_Type - (Desig_Subtype, S, Related_Nod, For_Access => True); - return; - end if; + ------------------------------ + -- Complete_Private_Subtype -- + ------------------------------ - -- Enforce rule that the constraint is illegal if there is an - -- unconstrained view of the designated type. This means that the - -- partial view (either a private type declaration or a derivation - -- from a private type) has no discriminants. (Defect Report - -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). + procedure Complete_Private_Subtype + (Priv : Entity_Id; + Full : Entity_Id; + Full_Base : Entity_Id; + Related_Nod : Node_Id) + is + Save_Next_Entity : Entity_Id; + Save_Homonym : Entity_Id; - -- Rule updated for Ada 2005: The private type is said to have - -- a constrained partial view, given that objects of the type - -- can be declared. Furthermore, the rule applies to all access - -- types, unlike the rule concerning default discriminants (see - -- RM 3.7.1(7/3)) + 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. + + -- 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. - 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) - then - declare - Pack : constant Node_Id := - Unit_Declaration_Node (Scope (Desig_Type)); - Decls : List_Id; - Decl : Node_Id; + Save_Next_Entity := Next_Entity (Full); + Save_Homonym := Homonym (Priv); - begin - if Nkind (Pack) = N_Package_Declaration then - Decls := Visible_Declarations (Specification (Pack)); - Decl := First (Decls); - while Present (Decl) loop - if (Nkind (Decl) = N_Private_Type_Declaration - and then - Chars (Defining_Identifier (Decl)) = - Chars (Desig_Type)) + case Ekind (Full_Base) is + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + Private_Kind | + Task_Kind | + Protected_Kind => + Copy_Node (Priv, Full); - or else - (Nkind (Decl) = N_Full_Type_Declaration - and then - Chars (Defining_Identifier (Decl)) = - Chars (Desig_Type) - and then Is_Derived_Type (Desig_Type) - and then - Has_Private_Declaration (Etype (Desig_Type))) - then - if No (Discriminant_Specifications (Decl)) then - Error_Msg_N - ("cannot constrain access type if designated " & - "type has constrained partial view", S); - end if; + Set_Has_Discriminants + (Full, Has_Discriminants (Full_Base)); + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); + Set_First_Entity (Full, First_Entity (Full_Base)); + Set_Last_Entity (Full, Last_Entity (Full_Base)); - exit; - end if; + -- If the underlying base type is constrained, we know that the + -- full view of the subtype is constrained as well (the converse + -- is not necessarily true). - Next (Decl); - end loop; - end if; - end; - end if; + if Is_Constrained (Full_Base) then + Set_Is_Constrained (Full); + end if; - Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, - For_Access => True); + when others => + Copy_Node (Full_Base, Full); - 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, ' '); + Set_Chars (Full, Chars (Priv)); + Conditional_Delay (Full, Priv); + Set_Sloc (Full, Sloc (Priv)); + end case; - else - Error_Msg_N ("invalid constraint on access type", S); - Desig_Subtype := Desig_Type; -- Ignore invalid constraint. - Constraint_OK := False; - end if; + Set_Next_Entity (Full, Save_Next_Entity); + Set_Homonym (Full, Save_Homonym); + Set_Associated_Node_For_Itype (Full, Related_Nod); - if No (Def_Id) then - Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); - else - Set_Ekind (Def_Id, E_Access_Subtype); - end if; + -- Set common attributes for all subtypes: kind, convention, etc. - if Constraint_OK then - Set_Etype (Def_Id, Base_Type (T)); + Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + Set_Convention (Full, Convention (Full_Base)); - if Is_Private_Type (Desig_Type) then - Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); - end if; - else - Set_Etype (Def_Id, Any_Type); - end if; + -- 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: - Set_Size_Info (Def_Id, T); - Set_Is_Constrained (Def_Id, Constraint_OK); - Set_Directly_Designated_Type (Def_Id, Desig_Subtype); - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); + -- Set_Etype (Full, Full_Base); - Conditional_Delay (Def_Id, T); + -- then we get inconsistencies in the front-end (confusion between + -- views). Several outstanding bugs are related to this ??? - -- AI-363 : Subtypes of general access types whose designated types have - -- default discriminants are disallowed. In instances, the rule has to - -- be checked against the actual, of which T is the subtype. In a - -- generic body, the rule is checked assuming that the actual type has - -- defaulted discriminants. + Set_Is_First_Subtype (Full, False); + Set_Scope (Full, Scope (Priv)); + Set_Size_Info (Full, Full_Base); + Set_RM_Size (Full, RM_Size (Full_Base)); + Set_Is_Itype (Full); - if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then - if Ekind (Base_Type (T)) = E_General_Access_Type - and then Has_Defaulted_Discriminants (Desig_Type) - then - if Ada_Version < Ada_2005 then - Error_Msg_N - ("access subtype of general access type would not " & - "be allowed in Ada 2005?y?", S); - else - Error_Msg_N - ("access subtype of general access type not allowed", S); - end if; + -- A subtype of a private-type-without-discriminants, whose full-view + -- has discriminants with default expressions, is not constrained. - Error_Msg_N ("\discriminants have defaults", S); + if not Has_Discriminants (Priv) then + Set_Is_Constrained (Full, Is_Constrained (Full_Base)); - elsif Is_Access_Type (T) - and then Is_Generic_Type (Desig_Type) - and then Has_Discriminants (Desig_Type) - and then In_Package_Body (Current_Scope) - then - if Ada_Version < Ada_2005 then - Error_Msg_N - ("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); - end if; + if Has_Discriminants (Full_Base) then + Set_Discriminant_Constraint + (Full, Discriminant_Constraint (Full_Base)); - Error_Msg_N - ("\designated type is a discriminated formal", S); + -- The partial view may have been indefinite, the full view + -- might not be. + + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); end if; end if; - end Constrain_Access; - - --------------------- - -- Constrain_Array -- - --------------------- - procedure Constrain_Array - (Def_Id : in out Entity_Id; - SI : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id; - Suffix : Character) - is - C : constant Node_Id := Constraint (SI); - Number_Of_Constraints : Nat := 0; - Index : Node_Id; - S, T : Entity_Id; - Constraint_OK : Boolean := True; + Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); + Set_Depends_On_Private (Full, Has_Private_Component (Full)); - begin - T := Entity (Subtype_Mark (SI)); + -- Freeze the private subtype entity if its parent is delayed, and not + -- already frozen. We skip this processing if the type is an anonymous + -- subtype of a record component, or is the corresponding record of a + -- protected type, since ??? - if Is_Access_Type (T) then - T := Designated_Type (T); + if not Is_Type (Scope (Full)) then + Set_Has_Delayed_Freeze (Full, + Has_Delayed_Freeze (Full_Base) + and then (not Is_Frozen (Full_Base))); end if; - -- If an index constraint follows a subtype mark in a subtype indication - -- then the type or subtype denoted by the subtype mark must not already - -- impose an index constraint. The subtype mark must denote either an - -- unconstrained array type or an access type whose designated type - -- is such an array type... (RM 3.6.1) + Set_Freeze_Node (Full, Empty); + Set_Is_Frozen (Full, False); + Set_Full_View (Priv, Full); - if Is_Constrained (T) then - Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); - Constraint_OK := False; + if Has_Discriminants (Full) then + Set_Stored_Constraint_From_Discriminant_Constraint (Full); + Set_Stored_Constraint (Priv, Stored_Constraint (Full)); - else - S := First (Constraints (C)); - while Present (S) loop - Number_Of_Constraints := Number_Of_Constraints + 1; - Next (S); - end loop; + if Has_Unknown_Discriminants (Full) then + Set_Discriminant_Constraint (Full, No_Elist); + end if; + end if; - -- In either case, the index constraint must provide a discrete - -- range for each index of the array type and the type of each - -- discrete range must be the same as that of the corresponding - -- index. (RM 3.6.1) + if Ekind (Full_Base) = E_Record_Type + and then Has_Discriminants (Full_Base) + and then Has_Discriminants (Priv) -- might not, if errors + and then not Has_Unknown_Discriminants (Priv) + and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) + then + Create_Constrained_Components + (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); - if Number_Of_Constraints /= Number_Dimensions (T) then - Error_Msg_NE ("incorrect number of index constraints for }", C, T); - Constraint_OK := False; + -- If the full base is itself derived from private, build a congruent + -- subtype of its underlying type, for use by the back end. For a + -- constrained record component, the declaration cannot be placed on + -- the component list, but it must nevertheless be built an analyzed, to + -- supply enough information for Gigi to compute the size of component. - else - S := First (Constraints (C)); - Index := First_Index (T); - Analyze (Index); + elsif Ekind (Full_Base) in Private_Kind + and then Is_Derived_Type (Full_Base) + and then Has_Discriminants (Full_Base) + and then (Ekind (Current_Scope) /= E_Record_Subtype) + then + if not Is_Itype (Priv) + and then + Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication + then + Build_Underlying_Full_View + (Parent (Priv), Full, Etype (Full_Base)); - -- Apply constraints to each index type + elsif Nkind (Related_Nod) = N_Component_Declaration then + Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); + end if; - for J in 1 .. Number_Of_Constraints loop - Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); - Next (Index); - Next (S); - end loop; + elsif Is_Record_Type (Full_Base) then - end if; + -- Show Full is simply a renaming of Full_Base + + Set_Cloned_Subtype (Full, Full_Base); end if; - if No (Def_Id) then - Def_Id := - Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); - Set_Parent (Def_Id, Related_Nod); + -- It is unsafe to share the bounds of a scalar type, because the Itype + -- is elaborated on demand, and if a bound is non-static then different + -- orders of elaboration in different units will lead to different + -- external symbols. - else - Set_Ekind (Def_Id, E_Array_Subtype); - end if; + if Is_Scalar_Type (Full_Base) then + Set_Scalar_Range (Full, + Make_Range (Sloc (Related_Nod), + Low_Bound => + Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), + High_Bound => + Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Etype (Def_Id, Base_Type (T)); + -- This completion inherits the bounds of the full parent, but if + -- the parent is an unconstrained floating point type, so is the + -- completion. - if Constraint_OK then - Set_First_Index (Def_Id, First (Constraints (C))); - else - Set_First_Index (Def_Id, First_Index (T)); + if Is_Floating_Point_Type (Full_Base) then + Set_Includes_Infinities + (Scalar_Range (Full), Has_Infinities (Full_Base)); + end if; end if; - Set_Is_Constrained (Def_Id, True); - Set_Is_Aliased (Def_Id, Is_Aliased (T)); - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - - Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); - Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); + -- ??? It seems that a lot of fields are missing that should be copied + -- from Full_Base to Full. Here are some that are introduced in a + -- non-disruptive way but a cleanup is necessary. - -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. - -- We need to initialize the attribute because if Def_Id is previously - -- analyzed through a limited_with clause, it will have the attributes - -- of an incomplete type, one of which is an Elist that overlaps the - -- Packed_Array_Impl_Type field. + if Is_Tagged_Type (Full_Base) then + Set_Is_Tagged_Type (Full); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Full_Base)); - Set_Packed_Array_Impl_Type (Def_Id, Empty); + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. - -- Build a freeze node if parent still needs one. Also make sure that - -- the Depends_On_Private status is set because the subtype will need - -- reprocessing at the time the base type does, and also we must set a - -- conditional delay. + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; - Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); - Conditional_Delay (Def_Id, T); - end Constrain_Array; + -- If this is a subtype of a protected or task type, constrain its + -- corresponding record, unless this is a subtype without constraints, + -- i.e. a simple renaming as with an actual subtype in an instance. - ------------------------------ - -- Constrain_Component_Type -- - ------------------------------ + elsif Is_Concurrent_Type (Full_Base) then + if Has_Discriminants (Full) + and then Present (Corresponding_Record_Type (Full_Base)) + and then + not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) + then + Set_Corresponding_Record_Type (Full, + Constrain_Corresponding_Record + (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); - function Constrain_Component_Type - (Comp : Entity_Id; - Constrained_Typ : Entity_Id; - Related_Node : Node_Id; - Typ : Entity_Id; - Constraints : Elist_Id) return Entity_Id - is - Loc : constant Source_Ptr := Sloc (Constrained_Typ); - Compon_Type : constant Entity_Id := Etype (Comp); + else + Set_Corresponding_Record_Type (Full, + Corresponding_Record_Type (Full_Base)); + end if; + end if; - function Build_Constrained_Array_Type - (Old_Type : Entity_Id) return Entity_Id; - -- If Old_Type is an array type, one of whose indexes is constrained - -- by a discriminant, build an Itype whose constraint replaces the - -- discriminant with its value in the constraint. + -- Link rep item chain, and also setting of Has_Predicates from private + -- subtype to full subtype, since we will need these on the full subtype + -- to create the predicate function. Note that the full subtype may + -- already have rep items, inherited from the full view of the base + -- type, so we must be sure not to overwrite these entries. - function Build_Constrained_Discriminated_Type - (Old_Type : Entity_Id) return Entity_Id; - -- Ditto for record components - - function Build_Constrained_Access_Type - (Old_Type : Entity_Id) return Entity_Id; - -- Ditto for access types. Makes use of previous two functions, to - -- constrain designated type. - - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; - -- T is an array or discriminated type, C is a list of constraints - -- that apply to T. This routine builds the constrained subtype. - - function Is_Discriminant (Expr : Node_Id) return Boolean; - -- Returns True if Expr is a discriminant - - function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; - -- Find the value of discriminant Discrim in Constraint - - ----------------------------------- - -- Build_Constrained_Access_Type -- - ----------------------------------- - - function Build_Constrained_Access_Type - (Old_Type : Entity_Id) return Entity_Id - is - Desig_Type : constant Entity_Id := Designated_Type (Old_Type); - Itype : Entity_Id; - Desig_Subtype : Entity_Id; - Scop : Entity_Id; + declare + Append : Boolean; + Item : Node_Id; + Next_Item : Node_Id; begin - -- if the original access type was not embedded in the enclosing - -- type definition, there is no need to produce a new access - -- subtype. In fact every access type with an explicit constraint - -- generates an itype whose scope is the enclosing record. - - if not Is_Type (Scope (Old_Type)) then - return Old_Type; + Item := First_Rep_Item (Full); - elsif Is_Array_Type (Desig_Type) then - Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); + -- If no existing rep items on full type, we can just link directly + -- to the list of items on the private type. - elsif Has_Discriminants (Desig_Type) then + if No (Item) then + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); - -- This may be an access type to an enclosing record type for - -- which we are constructing the constrained components. Return - -- the enclosing record subtype. This is not always correct, - -- but avoids infinite recursion. ??? + -- Otherwise, search to the end of items currently linked to the full + -- subtype and append the private items to the end. However, if Priv + -- and Full already have the same list of rep items, then the append + -- is not done, as that would create a circularity. - Desig_Subtype := Any_Type; + elsif Item /= First_Rep_Item (Priv) then + Append := True; + loop + Next_Item := Next_Rep_Item (Item); + exit when No (Next_Item); + Item := Next_Item; - for J in reverse 0 .. Scope_Stack.Last loop - Scop := Scope_Stack.Table (J).Entity; + -- If the private view has aspect specifications, the full view + -- inherits them. Since these aspects may already have been + -- attached to the full view during derivation, do not append + -- them if already present. - if Is_Type (Scop) - and then Base_Type (Scop) = Base_Type (Desig_Type) - then - Desig_Subtype := Scop; + if Item = First_Rep_Item (Priv) then + Append := False; + exit; end if; - - exit when not Is_Type (Scop); end loop; - if Desig_Subtype = Any_Type then - Desig_Subtype := - Build_Constrained_Discriminated_Type (Desig_Type); - end if; + -- And link the private type items at the end of the chain - else - return Old_Type; + if Append then + Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + end if; end if; + end; - if Desig_Subtype /= Desig_Type then - - -- The Related_Node better be here or else we won't be able - -- to attach new itypes to a node in the tree. - - pragma Assert (Present (Related_Node)); - - Itype := Create_Itype (E_Access_Subtype, Related_Node); + -- Make sure Has_Predicates is set on full type if it is set on the + -- private type. Note that it may already be set on the full type and + -- if so, we don't want to unset it. - Set_Etype (Itype, Base_Type (Old_Type)); - Set_Size_Info (Itype, (Old_Type)); - Set_Directly_Designated_Type (Itype, Desig_Subtype); - Set_Depends_On_Private (Itype, Has_Private_Component - (Old_Type)); - Set_Is_Access_Constant (Itype, Is_Access_Constant - (Old_Type)); + if Has_Predicates (Priv) then + Set_Has_Predicates (Full); + end if; + end Complete_Private_Subtype; - -- The new itype needs freezing when it depends on a not frozen - -- type and the enclosing subtype needs freezing. + ---------------------------- + -- Constant_Redeclaration -- + ---------------------------- - if Has_Delayed_Freeze (Constrained_Typ) - and then not Is_Frozen (Constrained_Typ) - then - Conditional_Delay (Itype, Base_Type (Old_Type)); - end if; + procedure Constant_Redeclaration + (Id : Entity_Id; + N : Node_Id; + T : out Entity_Id) + is + Prev : constant Entity_Id := Current_Entity_In_Scope (Id); + Obj_Def : constant Node_Id := Object_Definition (N); + New_T : Entity_Id; - return Itype; + 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. - else - return Old_Type; - end if; - end Build_Constrained_Access_Type; + 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, + -- through a default value of some record subcomponent. This is normally + -- detected when generating init procs, but requires this additional + -- mechanism when expansion is disabled. - ---------------------------------- - -- Build_Constrained_Array_Type -- - ---------------------------------- + ---------------------------------------- + -- Check_Possible_Deferred_Completion -- + ---------------------------------------- - function Build_Constrained_Array_Type - (Old_Type : Entity_Id) return Entity_Id + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id) is - Lo_Expr : Node_Id; - Hi_Expr : Node_Id; - Old_Index : Node_Id; - Range_Node : Node_Id; - Constr_List : List_Id; - - Need_To_Create_Itype : Boolean := False; - begin - Old_Index := First_Index (Old_Type); - while Present (Old_Index) loop - Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + 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_Temporary (Loc, 'S'); + Decl : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => + Relocate_Node (Curr_Obj_Def)); - if Is_Discriminant (Lo_Expr) - or else Is_Discriminant (Hi_Expr) - then - Need_To_Create_Itype := True; - end if; + begin + Insert_Before_And_Analyze (N, Decl); + Set_Etype (Id, Def_Id); - Next_Index (Old_Index); - end loop; + 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; - if Need_To_Create_Itype then - Constr_List := New_List; + --------------------------------- + -- Check_Recursive_Declaration -- + --------------------------------- - Old_Index := First_Index (Old_Type); - while Present (Old_Index) loop - Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + procedure Check_Recursive_Declaration (Typ : Entity_Id) is + Comp : Entity_Id; - if Is_Discriminant (Lo_Expr) then - Lo_Expr := Get_Discr_Value (Lo_Expr); - end if; + begin + if Is_Record_Type (Typ) then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) then + if Present (Expression (Parent (Comp))) + and then Is_Entity_Name (Expression (Parent (Comp))) + and then Entity (Expression (Parent (Comp))) = Prev + then + Error_Msg_Sloc := Sloc (Parent (Comp)); + Error_Msg_NE + ("illegal circularity with declaration for & #", + N, Comp); + return; - if Is_Discriminant (Hi_Expr) then - Hi_Expr := Get_Discr_Value (Hi_Expr); + elsif Is_Record_Type (Etype (Comp)) then + Check_Recursive_Declaration (Etype (Comp)); + end if; end if; - Range_Node := - Make_Range - (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); - - Append (Range_Node, To => Constr_List); - - Next_Index (Old_Index); + Next_Component (Comp); end loop; - - return Build_Subtype (Old_Type, Constr_List); - - else - return Old_Type; end if; - end Build_Constrained_Array_Type; + end Check_Recursive_Declaration; - ------------------------------------------ - -- Build_Constrained_Discriminated_Type -- - ------------------------------------------ + -- Start of processing for Constant_Redeclaration - function Build_Constrained_Discriminated_Type - (Old_Type : Entity_Id) return Entity_Id - is - Expr : Node_Id; - Constr_List : List_Id; - Old_Constraint : Elmt_Id; - - Need_To_Create_Itype : Boolean := False; + begin + if Nkind (Parent (Prev)) = N_Object_Declaration then + if Nkind (Object_Definition + (Parent (Prev))) = N_Subtype_Indication + then + -- Find type of new declaration. The constraints of the two + -- views must match statically, but there is no point in + -- creating an itype for the full view. - begin - Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); - while Present (Old_Constraint) loop - Expr := Node (Old_Constraint); + if Nkind (Obj_Def) = N_Subtype_Indication then + Find_Type (Subtype_Mark (Obj_Def)); + New_T := Entity (Subtype_Mark (Obj_Def)); - if Is_Discriminant (Expr) then - Need_To_Create_Itype := True; + else + Find_Type (Obj_Def); + New_T := Entity (Obj_Def); end if; - Next_Elmt (Old_Constraint); - end loop; + T := Etype (Prev); - if Need_To_Create_Itype then - Constr_List := New_List; + else + -- The full view may impose a constraint, even if the partial + -- view does not, so construct the subtype. - Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); - while Present (Old_Constraint) loop - Expr := Node (Old_Constraint); + New_T := Find_Type_Of_Object (Obj_Def, N); + T := New_T; + end if; - if Is_Discriminant (Expr) then - Expr := Get_Discr_Value (Expr); - end if; + else + -- Current declaration is illegal, diagnosed below in Enter_Name - Append (New_Copy_Tree (Expr), To => Constr_List); + T := Empty; + New_T := Any_Type; + end if; - Next_Elmt (Old_Constraint); - end loop; + -- If previous full declaration or a renaming declaration exists, or if + -- a homograph is present, let Enter_Name handle it, either with an + -- error or with the removal of an overridden implicit subprogram. + -- The previous one is a full declaration if it has an expression + -- (which in the case of an aggregate is indicated by the Init flag). - return Build_Subtype (Old_Type, Constr_List); + if Ekind (Prev) /= E_Constant + or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration + or else Present (Expression (Parent (Prev))) + or else Has_Init_Expression (Parent (Prev)) + or else Present (Full_View (Prev)) + then + Enter_Name (Id); - else - return Old_Type; - end if; - end Build_Constrained_Discriminated_Type; + -- Verify that types of both declarations match, or else that both types + -- are anonymous access types whose designated subtypes statically match + -- (as allowed in Ada 2005 by AI-385). - ------------------- - -- Build_Subtype -- - ------------------- + elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) + and then + (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type + or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type + or else Is_Access_Constant (Etype (New_T)) /= + Is_Access_Constant (Etype (Prev)) + or else Can_Never_Be_Null (Etype (New_T)) /= + Can_Never_Be_Null (Etype (Prev)) + or else Null_Exclusion_Present (Parent (Prev)) /= + Null_Exclusion_Present (Parent (Id)) + or else not Subtypes_Statically_Match + (Designated_Type (Etype (Prev)), + Designated_Type (Etype (New_T)))) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("type does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is - Indic : Node_Id; - Subtyp_Decl : Node_Id; - Def_Id : Entity_Id; - Btyp : Entity_Id := Base_Type (T); + elsif + Null_Exclusion_Present (Parent (Prev)) + and then not Null_Exclusion_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("null-exclusion does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); - begin - -- The Related_Node better be here or else we won't be able to - -- attach new itypes to a node in the tree. + -- If so, process the full constant declaration - pragma Assert (Present (Related_Node)); + 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. - -- If the view of the component's type is incomplete or private - -- with unknown discriminants, then the constraint must be applied - -- to the full type. + Check_Possible_Deferred_Completion + (Prev_Id => Prev, + Prev_Obj_Def => Object_Definition (Parent (Prev)), + Curr_Obj_Def => Obj_Def); - if Has_Unknown_Discriminants (Btyp) - and then Present (Underlying_Type (Btyp)) + Set_Full_View (Prev, Id); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + Append_Entity (Id, Current_Scope); + + -- Check ALIASED present if present before (RM 7.4(7)) + + if Is_Aliased (Prev) + and then not Aliased_Present (N) then - Btyp := Underlying_Type (Btyp); + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("ALIASED required (see declaration #)", N); end if; - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Btyp, Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); + -- Check that placement is in private part and that the incomplete + -- declaration appeared in the visible part. - Def_Id := Create_Itype (Ekind (T), Related_Node); + if Ekind (Current_Scope) = E_Package + and then not In_Private_Part (Current_Scope) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N + ("full constant for declaration#" + & " must be in private part", N); - Subtyp_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => Indic); + elsif Ekind (Current_Scope) = E_Package + and then + List_Containing (Parent (Prev)) /= + Visible_Declarations (Package_Specification (Current_Scope)) + then + Error_Msg_N + ("deferred constant must be declared in visible part", + Parent (Prev)); + end if; - Set_Parent (Subtyp_Decl, Parent (Related_Node)); + if Is_Access_Type (T) + and then Nkind (Expression (N)) = N_Allocator + then + Check_Recursive_Declaration (Designated_Type (T)); + end if; - -- Itypes must be analyzed with checks off (see package Itypes) + -- A deferred constant is a visible entity. If type has invariants, + -- verify that the initial value satisfies them. - Analyze (Subtyp_Decl, Suppress => All_Checks); + if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); + end if; + end if; + end Constant_Redeclaration; - return Def_Id; - end Build_Subtype; + ---------------------- + -- Constrain_Access -- + ---------------------- - --------------------- - -- Get_Discr_Value -- - --------------------- + procedure Constrain_Access + (Def_Id : in out Entity_Id; + S : Node_Id; + Related_Nod : Node_Id) + is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + Desig_Type : constant Entity_Id := Designated_Type (T); + Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); + Constraint_OK : Boolean := True; - function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is - D : Entity_Id; - E : Elmt_Id; + begin + if Is_Array_Type (Desig_Type) then + Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); - begin - -- The discriminant may be declared for the type, in which case we - -- find it by iterating over the list of discriminants. If the - -- discriminant is inherited from a parent type, it appears as the - -- corresponding discriminant of the current type. This will be the - -- case when constraining an inherited component whose constraint is - -- given by a discriminant of the parent. + elsif (Is_Record_Type (Desig_Type) + or else Is_Incomplete_Or_Private_Type (Desig_Type)) + and then not Is_Constrained (Desig_Type) + then + -- ??? The following code is a temporary bypass to ignore a + -- discriminant constraint on access type if it is constraining + -- the current record. Avoid creating the implicit subtype of the + -- record we are currently compiling since right now, we cannot + -- handle these. For now, just return the access type itself. - D := First_Discriminant (Typ); - E := First_Elmt (Constraints); + if Desig_Type = Current_Scope + and then No (Def_Id) + then + Set_Ekind (Desig_Subtype, E_Record_Subtype); + Def_Id := Entity (Subtype_Mark (S)); - while Present (D) loop - if D = Entity (Discrim) - or else D = CR_Discriminant (Entity (Discrim)) - or else Corresponding_Discriminant (D) = Entity (Discrim) - then - return Node (E); - end if; + -- This call added to ensure that the constraint is analyzed + -- (needed for a B test). Note that we still return early from + -- this procedure to avoid recursive processing. ??? - Next_Discriminant (D); - Next_Elmt (E); - end loop; + Constrain_Discriminated_Type + (Desig_Subtype, S, Related_Nod, For_Access => True); + return; + end if; - -- The Corresponding_Discriminant mechanism is incomplete, because - -- the correspondence between new and old discriminants is not one - -- to one: one new discriminant can constrain several old ones. In - -- that case, scan sequentially the stored_constraint, the list of - -- discriminants of the parents, and the constraints. + -- Enforce rule that the constraint is illegal if there is an + -- unconstrained view of the designated type. This means that the + -- partial view (either a private type declaration or a derivation + -- from a private type) has no discriminants. (Defect Report + -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). - -- Previous code checked for the present of the Stored_Constraint - -- list for the derived type, but did not use it at all. Should it - -- be present when the component is a discriminated task type? + -- Rule updated for Ada 2005: The private type is said to have + -- a constrained partial view, given that objects of the type + -- can be declared. Furthermore, the rule applies to all access + -- types, unlike the rule concerning default discriminants (see + -- RM 3.7.1(7/3)) - if Is_Derived_Type (Typ) - and then Scope (Entity (Discrim)) = Etype (Typ) + 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) then - D := First_Discriminant (Etype (Typ)); - E := First_Elmt (Constraints); - while Present (D) loop - if D = Entity (Discrim) then - return Node (E); - end if; - - Next_Discriminant (D); - Next_Elmt (E); - end loop; - end if; - - -- Something is wrong if we did not find the value - - raise Program_Error; - end Get_Discr_Value; - - --------------------- - -- Is_Discriminant -- - --------------------- - - function Is_Discriminant (Expr : Node_Id) return Boolean is - Discrim_Scope : Entity_Id; - - begin - if Denotes_Discriminant (Expr) then - Discrim_Scope := Scope (Entity (Expr)); - - -- Either we have a reference to one of Typ's discriminants, - - pragma Assert (Discrim_Scope = Typ - - -- or to the discriminants of the parent type, in the case - -- of a derivation of a tagged type with variants. + declare + Pack : constant Node_Id := + Unit_Declaration_Node (Scope (Desig_Type)); + Decls : List_Id; + Decl : Node_Id; - or else Discrim_Scope = Etype (Typ) - or else Full_View (Discrim_Scope) = Etype (Typ) + begin + if Nkind (Pack) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (Pack)); + Decl := First (Decls); + while Present (Decl) loop + if (Nkind (Decl) = N_Private_Type_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type)) - -- or same as above for the case where the discriminants - -- were declared in Typ's private view. + or else + (Nkind (Decl) = N_Full_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type) + and then Is_Derived_Type (Desig_Type) + and then + Has_Private_Declaration (Etype (Desig_Type))) + then + if No (Discriminant_Specifications (Decl)) then + Error_Msg_N + ("cannot constrain access type if designated " + & "type has constrained partial view", S); + end if; - or else (Is_Private_Type (Discrim_Scope) - and then Chars (Discrim_Scope) = Chars (Typ)) + exit; + end if; - -- or else we are deriving from the full view and the - -- discriminant is declared in the private entity. + Next (Decl); + end loop; + end if; + end; + end if; - or else (Is_Private_Type (Typ) - and then Chars (Discrim_Scope) = Chars (Typ)) + Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, + For_Access => True); - -- Or we are constrained the corresponding record of a - -- synchronized type that completes a private declaration. + 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, ' '); - or else (Is_Concurrent_Record_Type (Typ) - and then - Corresponding_Concurrent_Type (Typ) = Discrim_Scope) + else + Error_Msg_N ("invalid constraint on access type", S); + Desig_Subtype := Desig_Type; -- Ignore invalid constraint + Constraint_OK := False; + end if; - -- or we have a class-wide type, in which case make sure the - -- discriminant found belongs to the root type. + if No (Def_Id) then + Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); + else + Set_Ekind (Def_Id, E_Access_Subtype); + end if; - or else (Is_Class_Wide_Type (Typ) - and then Etype (Typ) = Discrim_Scope)); + if Constraint_OK then + Set_Etype (Def_Id, Base_Type (T)); - return True; + if Is_Private_Type (Desig_Type) then + Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); end if; + else + Set_Etype (Def_Id, Any_Type); + end if; - -- In all other cases we have something wrong - - return False; - end Is_Discriminant; + Set_Size_Info (Def_Id, T); + Set_Is_Constrained (Def_Id, Constraint_OK); + Set_Directly_Designated_Type (Def_Id, Desig_Subtype); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); - -- Start of processing for Constrain_Component_Type + Conditional_Delay (Def_Id, T); - begin - if Nkind (Parent (Comp)) = N_Component_Declaration - and then Comes_From_Source (Parent (Comp)) - and then Comes_From_Source - (Subtype_Indication (Component_Definition (Parent (Comp)))) - and then - Is_Entity_Name - (Subtype_Indication (Component_Definition (Parent (Comp)))) - then - return Compon_Type; + -- AI-363 : Subtypes of general access types whose designated types have + -- default discriminants are disallowed. In instances, the rule has to + -- be checked against the actual, of which T is the subtype. In a + -- generic body, the rule is checked assuming that the actual type has + -- defaulted discriminants. - elsif Is_Array_Type (Compon_Type) then - return Build_Constrained_Array_Type (Compon_Type); + if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then + if Ekind (Base_Type (T)) = E_General_Access_Type + and then Has_Defaulted_Discriminants (Desig_Type) + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("access subtype of general access type would not " & + "be allowed in Ada 2005?y?", S); + else + Error_Msg_N + ("access subtype of general access type not allowed", S); + end if; - elsif Has_Discriminants (Compon_Type) then - return Build_Constrained_Discriminated_Type (Compon_Type); + Error_Msg_N ("\discriminants have defaults", S); - elsif Is_Access_Type (Compon_Type) then - return Build_Constrained_Access_Type (Compon_Type); + elsif Is_Access_Type (T) + and then Is_Generic_Type (Desig_Type) + and then Has_Discriminants (Desig_Type) + and then In_Package_Body (Current_Scope) + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("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); + end if; - else - return Compon_Type; + Error_Msg_N + ("\designated type is a discriminated formal", S); + end if; end if; - end Constrain_Component_Type; - - -------------------------- - -- Constrain_Concurrent -- - -------------------------- + end Constrain_Access; - -- For concurrent types, the associated record value type carries the same - -- discriminants, so when we constrain a concurrent type, we must constrain - -- the corresponding record type as well. + --------------------- + -- Constrain_Array -- + --------------------- - procedure Constrain_Concurrent + procedure Constrain_Array (Def_Id : in out Entity_Id; SI : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id; Suffix : Character) is - -- Retrieve Base_Type to ensure getting to the concurrent type in the - -- case of a private subtype (needed when only doing semantic analysis). - - T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); - T_Val : Entity_Id; + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + Constraint_OK : Boolean := True; begin - if Is_Access_Type (T_Ent) then - T_Ent := Designated_Type (T_Ent); + T := Entity (Subtype_Mark (SI)); + + if Is_Access_Type (T) then + T := Designated_Type (T); end if; - T_Val := Corresponding_Record_Type (T_Ent); + -- If an index constraint follows a subtype mark in a subtype indication + -- then the type or subtype denoted by the subtype mark must not already + -- impose an index constraint. The subtype mark must denote either an + -- unconstrained array type or an access type whose designated type + -- is such an array type... (RM 3.6.1) - if Present (T_Val) then + if Is_Constrained (T) then + Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); + Constraint_OK := False; - if No (Def_Id) then - Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; + else + S := First (Constraints (C)); + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; - Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - Set_Corresponding_Record_Type (Def_Id, - Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); + if Number_Of_Constraints /= Number_Dimensions (T) then + Error_Msg_NE ("incorrect number of index constraints for }", C, T); + Constraint_OK := False; - else - -- If there is no associated record, expansion is disabled and this - -- is a generic context. Create a subtype in any case, so that - -- semantic analysis can proceed. + else + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); - if No (Def_Id) then - Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; + -- Apply constraints to each index type - Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); - end if; - end Constrain_Concurrent; + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); + Next (Index); + Next (S); + end loop; - ------------------------------------ - -- Constrain_Corresponding_Record -- - ------------------------------------ + end if; + end if; - function Constrain_Corresponding_Record - (Prot_Subt : Entity_Id; - Corr_Rec : Entity_Id; - Related_Nod : Node_Id) return Entity_Id - is - T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); + if No (Def_Id) then + Def_Id := + Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); + Set_Parent (Def_Id, Related_Nod); - begin - Set_Etype (T_Sub, Corr_Rec); - Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); - Set_Is_Constrained (T_Sub, True); - Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); - Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); + else + Set_Ekind (Def_Id, E_Array_Subtype); + end if; - if Has_Discriminants (Prot_Subt) then -- False only if errors. - Set_Discriminant_Constraint - (T_Sub, Discriminant_Constraint (Prot_Subt)); - Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); - Create_Constrained_Components - (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Etype (Def_Id, Base_Type (T)); + + if Constraint_OK then + Set_First_Index (Def_Id, First (Constraints (C))); + else + Set_First_Index (Def_Id, First_Index (T)); end if; - Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); + Set_Is_Constrained (Def_Id, True); + Set_Is_Aliased (Def_Id, Is_Aliased (T)); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - if Ekind (Scope (Prot_Subt)) /= E_Record_Type then - Conditional_Delay (T_Sub, Corr_Rec); + Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); + Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); - else - -- This is a component subtype: it will be frozen in the context of - -- the enclosing record's init_proc, so that discriminant references - -- are resolved to discriminals. (Note: we used to skip freezing - -- altogether in that case, which caused errors downstream for - -- components of a bit packed array type). + -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. + -- We need to initialize the attribute because if Def_Id is previously + -- analyzed through a limited_with clause, it will have the attributes + -- of an incomplete type, one of which is an Elist that overlaps the + -- Packed_Array_Impl_Type field. - Set_Has_Delayed_Freeze (T_Sub); - end if; + Set_Packed_Array_Impl_Type (Def_Id, Empty); - return T_Sub; - end Constrain_Corresponding_Record; + -- Build a freeze node if parent still needs one. Also make sure that + -- the Depends_On_Private status is set because the subtype will need + -- reprocessing at the time the base type does, and also we must set a + -- conditional delay. - ----------------------- - -- Constrain_Decimal -- - ----------------------- + Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); + Conditional_Delay (Def_Id, T); + end Constrain_Array; - procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); - Loc : constant Source_Ptr := Sloc (C); - Range_Expr : Node_Id; - Digits_Expr : Node_Id; - Digits_Val : Uint; - Bound_Val : Ureal; + ------------------------------ + -- Constrain_Component_Type -- + ------------------------------ - begin - Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); + function Constrain_Component_Type + (Comp : Entity_Id; + Constrained_Typ : Entity_Id; + Related_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Constrained_Typ); + Compon_Type : constant Entity_Id := Etype (Comp); - if Nkind (C) = N_Range_Constraint then - Range_Expr := Range_Expression (C); - Digits_Val := Digits_Value (T); + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id; + -- If Old_Type is an array type, one of whose indexes is constrained + -- by a discriminant, build an Itype whose constraint replaces the + -- discriminant with its value in the constraint. - else - pragma Assert (Nkind (C) = N_Digits_Constraint); + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for record components - Check_SPARK_05_Restriction ("digits constraint is not allowed", S); + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for access types. Makes use of previous two functions, to + -- constrain designated type. - Digits_Expr := Digits_Expression (C); - Analyze_And_Resolve (Digits_Expr, Any_Integer); + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; + -- T is an array or discriminated type, C is a list of constraints + -- that apply to T. This routine builds the constrained subtype. - Check_Digits_Expression (Digits_Expr); - Digits_Val := Expr_Value (Digits_Expr); + function Is_Discriminant (Expr : Node_Id) return Boolean; + -- Returns True if Expr is a discriminant - if Digits_Val > Digits_Value (T) then - Error_Msg_N - ("digits expression is incompatible with subtype", C); - Digits_Val := Digits_Value (T); - end if; + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; + -- Find the value of discriminant Discrim in Constraint - if Present (Range_Constraint (C)) then - Range_Expr := Range_Expression (Range_Constraint (C)); - else - Range_Expr := Empty; - end if; - end if; + ----------------------------------- + -- Build_Constrained_Access_Type -- + ----------------------------------- - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Delta_Value (Def_Id, Delta_Value (T)); - Set_Scale_Value (Def_Id, Scale_Value (T)); - Set_Small_Value (Def_Id, Small_Value (T)); - Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); - Set_Digits_Value (Def_Id, Digits_Val); + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id + is + Desig_Type : constant Entity_Id := Designated_Type (Old_Type); + Itype : Entity_Id; + Desig_Subtype : Entity_Id; + Scop : Entity_Id; - -- Manufacture range from given digits value if no range present + begin + -- if the original access type was not embedded in the enclosing + -- type definition, there is no need to produce a new access + -- subtype. In fact every access type with an explicit constraint + -- generates an itype whose scope is the enclosing record. - if No (Range_Expr) then - Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); - Range_Expr := - Make_Range (Loc, - Low_Bound => - Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), - High_Bound => - Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); - end if; + if not Is_Type (Scope (Old_Type)) then + return Old_Type; - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); - Set_Discrete_RM_Size (Def_Id); + elsif Is_Array_Type (Desig_Type) then + Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); - -- Unconditionally delay the freeze, since we cannot set size - -- information in all cases correctly until the freeze point. + elsif Has_Discriminants (Desig_Type) then - Set_Has_Delayed_Freeze (Def_Id); - end Constrain_Decimal; + -- This may be an access type to an enclosing record type for + -- which we are constructing the constrained components. Return + -- the enclosing record subtype. This is not always correct, + -- but avoids infinite recursion. ??? - ---------------------------------- - -- Constrain_Discriminated_Type -- - ---------------------------------- + Desig_Subtype := Any_Type; - procedure Constrain_Discriminated_Type - (Def_Id : Entity_Id; - S : Node_Id; - Related_Nod : Node_Id; - For_Access : Boolean := False) - is - E : constant Entity_Id := Entity (Subtype_Mark (S)); - T : Entity_Id; - C : Node_Id; - Elist : Elist_Id := New_Elmt_List; + for J in reverse 0 .. Scope_Stack.Last loop + Scop := Scope_Stack.Table (J).Entity; - procedure Fixup_Bad_Constraint; - -- This is called after finding a bad constraint, and after having - -- posted an appropriate error message. The mission is to leave the - -- entity T in as reasonable state as possible. + if Is_Type (Scop) + and then Base_Type (Scop) = Base_Type (Desig_Type) + then + Desig_Subtype := Scop; + end if; - -------------------------- - -- Fixup_Bad_Constraint -- - -------------------------- + exit when not Is_Type (Scop); + end loop; - procedure Fixup_Bad_Constraint is - begin - -- Set a reasonable Ekind for the entity. For an incomplete type, - -- we can't do much, but for other types, we can set the proper - -- corresponding subtype kind. + if Desig_Subtype = Any_Type then + Desig_Subtype := + Build_Constrained_Discriminated_Type (Desig_Type); + end if; - if Ekind (T) = E_Incomplete_Type then - Set_Ekind (Def_Id, Ekind (T)); else - Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + return Old_Type; end if; - -- Set Etype to the known type, to reduce chances of cascaded errors + if Desig_Subtype /= Desig_Type then - Set_Etype (Def_Id, E); - Set_Error_Posted (Def_Id); - end Fixup_Bad_Constraint; + -- The Related_Node better be here or else we won't be able + -- to attach new itypes to a node in the tree. - -- Start of processing for Constrain_Discriminated_Type + pragma Assert (Present (Related_Node)); - begin - C := Constraint (S); + Itype := Create_Itype (E_Access_Subtype, Related_Node); - -- A discriminant constraint is only allowed in a subtype indication, - -- after a subtype mark. This subtype mark must denote either a type - -- with discriminants, or an access type whose designated type is a - -- type with discriminants. A discriminant constraint specifies the - -- values of these discriminants (RM 3.7.2(5)). + Set_Etype (Itype, Base_Type (Old_Type)); + Set_Size_Info (Itype, (Old_Type)); + Set_Directly_Designated_Type (Itype, Desig_Subtype); + Set_Depends_On_Private (Itype, Has_Private_Component + (Old_Type)); + Set_Is_Access_Constant (Itype, Is_Access_Constant + (Old_Type)); - T := Base_Type (Entity (Subtype_Mark (S))); + -- The new itype needs freezing when it depends on a not frozen + -- type and the enclosing subtype needs freezing. - if Is_Access_Type (T) then - T := Designated_Type (T); - end if; + if Has_Delayed_Freeze (Constrained_Typ) + and then not Is_Frozen (Constrained_Typ) + then + Conditional_Delay (Itype, Base_Type (Old_Type)); + end if; - -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. - -- Avoid generating an error for access-to-incomplete subtypes. - - if Ada_Version >= Ada_2005 - and then Ekind (T) = E_Incomplete_Type - and then Nkind (Parent (S)) = N_Subtype_Declaration - and then not Is_Itype (Def_Id) - then - -- A little sanity check, emit an error message if the type - -- has discriminants to begin with. Type T may be a regular - -- incomplete type or imported via a limited with clause. + return Itype; - if Has_Discriminants (T) - or else (From_Limited_With (T) - and then Present (Non_Limited_View (T)) - and then Nkind (Parent (Non_Limited_View (T))) = - N_Full_Type_Declaration - and then Present (Discriminant_Specifications - (Parent (Non_Limited_View (T))))) - then - Error_Msg_N - ("(Ada 2005) incomplete subtype may not be constrained", C); else - Error_Msg_N ("invalid constraint: type has no discriminant", C); + return Old_Type; end if; + end Build_Constrained_Access_Type; - Fixup_Bad_Constraint; - return; + ---------------------------------- + -- Build_Constrained_Array_Type -- + ---------------------------------- - -- Check that the type has visible discriminants. The type may be - -- a private type with unknown discriminants whose full view has - -- discriminants which are invisible. + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id + is + Lo_Expr : Node_Id; + Hi_Expr : Node_Id; + Old_Index : Node_Id; + Range_Node : Node_Id; + Constr_List : List_Id; - elsif not Has_Discriminants (T) - or else - (Has_Unknown_Discriminants (T) - and then Is_Private_Type (T)) - then - Error_Msg_N ("invalid constraint: type has no discriminant", C); - Fixup_Bad_Constraint; - return; + Need_To_Create_Itype : Boolean := False; - elsif Is_Constrained (E) - or else (Ekind (E) = E_Class_Wide_Subtype - and then Present (Discriminant_Constraint (E))) - then - Error_Msg_N ("type is already constrained", Subtype_Mark (S)); - Fixup_Bad_Constraint; - return; - end if; + begin + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); - -- T may be an unconstrained subtype (e.g. a generic actual). - -- Constraint applies to the base type. + if Is_Discriminant (Lo_Expr) + or else Is_Discriminant (Hi_Expr) + then + Need_To_Create_Itype := True; + end if; - T := Base_Type (T); + Next_Index (Old_Index); + end loop; - Elist := Build_Discriminant_Constraints (T, S); + if Need_To_Create_Itype then + Constr_List := New_List; - -- If the list returned was empty we had an error in building the - -- discriminant constraint. We have also already signalled an error - -- in the incomplete type case + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); - if Is_Empty_Elmt_List (Elist) then - Fixup_Bad_Constraint; - return; - end if; + if Is_Discriminant (Lo_Expr) then + Lo_Expr := Get_Discr_Value (Lo_Expr); + end if; - Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); - end Constrain_Discriminated_Type; + if Is_Discriminant (Hi_Expr) then + Hi_Expr := Get_Discr_Value (Hi_Expr); + end if; - --------------------------- - -- Constrain_Enumeration -- - --------------------------- + Range_Node := + Make_Range + (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); - procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); + Append (Range_Node, To => Constr_List); - begin - Set_Ekind (Def_Id, E_Enumeration_Subtype); + Next_Index (Old_Index); + end loop; - Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + return Build_Subtype (Old_Type, Constr_List); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + else + return Old_Type; + end if; + end Build_Constrained_Array_Type; - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + ------------------------------------------ + -- Build_Constrained_Discriminated_Type -- + ------------------------------------------ - Set_Discrete_RM_Size (Def_Id); - end Constrain_Enumeration; + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id + is + Expr : Node_Id; + Constr_List : List_Id; + Old_Constraint : Elmt_Id; - ---------------------- - -- Constrain_Float -- - ---------------------- + Need_To_Create_Itype : Boolean := False; - procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : Node_Id; - D : Node_Id; - Rais : Node_Id; + begin + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); - begin - Set_Ekind (Def_Id, E_Floating_Point_Subtype); + if Is_Discriminant (Expr) then + Need_To_Create_Itype := True; + end if; - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Next_Elmt (Old_Constraint); + end loop; - -- Process the constraint + if Need_To_Create_Itype then + Constr_List := New_List; - C := Constraint (S); + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); - -- Digits constraint present + if Is_Discriminant (Expr) then + Expr := Get_Discr_Value (Expr); + end if; - if Nkind (C) = N_Digits_Constraint then + Append (New_Copy_Tree (Expr), To => Constr_List); - Check_SPARK_05_Restriction ("digits constraint is not allowed", S); - Check_Restriction (No_Obsolescent_Features, C); + Next_Elmt (Old_Constraint); + end loop; - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("subtype digits constraint is an " & - "obsolescent feature (RM J.3(8))?j?", C); + return Build_Subtype (Old_Type, Constr_List); + + else + return Old_Type; end if; + end Build_Constrained_Discriminated_Type; - D := Digits_Expression (C); - Analyze_And_Resolve (D, Any_Integer); - Check_Digits_Expression (D); - Set_Digits_Value (Def_Id, Expr_Value (D)); + ------------------- + -- Build_Subtype -- + ------------------- - -- Check that digits value is in range. Obviously we can do this - -- at compile time, but it is strictly a runtime check, and of - -- course there is an ACVC test that checks this. + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + Btyp : Entity_Id := Base_Type (T); - if Digits_Value (Def_Id) > Digits_Value (T) then - Error_Msg_Uint_1 := Digits_Value (T); - Error_Msg_N ("??digits value is too large, maximum is ^", D); - Rais := - Make_Raise_Constraint_Error (Sloc (D), - Reason => CE_Range_Check_Failed); - Insert_Action (Declaration_Node (Def_Id), Rais); - end if; + begin + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. - C := Range_Constraint (C); + pragma Assert (Present (Related_Node)); - -- No digits constraint present + -- If the view of the component's type is incomplete or private + -- with unknown discriminants, then the constraint must be applied + -- to the full type. - else - Set_Digits_Value (Def_Id, Digits_Value (T)); - end if; + if Has_Unknown_Discriminants (Btyp) + and then Present (Underlying_Type (Btyp)) + then + Btyp := Underlying_Type (Btyp); + end if; - -- Range constraint present + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); - if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Def_Id := Create_Itype (Ekind (T), Related_Node); - -- No range constraint present + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); - else - pragma Assert (No (C)); - Set_Scalar_Range (Def_Id, Scalar_Range (T)); - end if; + Set_Parent (Subtyp_Decl, Parent (Related_Node)); - Set_Is_Constrained (Def_Id); - end Constrain_Float; + -- Itypes must be analyzed with checks off (see package Itypes) - --------------------- - -- Constrain_Index -- - --------------------- + Analyze (Subtyp_Decl, Suppress => All_Checks); - procedure Constrain_Index - (Index : Node_Id; - S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id; - Suffix : Character; - Suffix_Index : Nat) - is - Def_Id : Entity_Id; - R : Node_Id := Empty; - T : constant Entity_Id := Etype (Index); + return Def_Id; + end Build_Subtype; - begin - if Nkind (S) = N_Range - or else - (Nkind (S) = N_Attribute_Reference - and then Attribute_Name (S) = Name_Range) - then - -- A Range attribute will be transformed into N_Range by Resolve + --------------------- + -- Get_Discr_Value -- + --------------------- - Analyze (S); - Set_Etype (S, T); - R := S; + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is + D : Entity_Id; + E : Elmt_Id; - Process_Range_Expr_In_Decl (R, T); + begin + -- The discriminant may be declared for the type, in which case we + -- find it by iterating over the list of discriminants. If the + -- discriminant is inherited from a parent type, it appears as the + -- corresponding discriminant of the current type. This will be the + -- case when constraining an inherited component whose constraint is + -- given by a discriminant of the parent. - if not Error_Posted (S) - and then - (Nkind (S) /= N_Range - or else not Covers (T, (Etype (Low_Bound (S)))) - or else not Covers (T, (Etype (High_Bound (S))))) - then - if Base_Type (T) /= Any_Type - and then Etype (Low_Bound (S)) /= Any_Type - and then Etype (High_Bound (S)) /= Any_Type + D := First_Discriminant (Typ); + E := First_Elmt (Constraints); + + while Present (D) loop + if D = Entity (Discrim) + or else D = CR_Discriminant (Entity (Discrim)) + or else Corresponding_Discriminant (D) = Entity (Discrim) then - Error_Msg_N ("range expected", S); + return Node (E); end if; - end if; - - elsif Nkind (S) = N_Subtype_Indication then - -- The parser has verified that this is a discrete indication - - Resolve_Discrete_Subtype_Indication (S, T); - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in index constraint", - S, Entity (Subtype_Mark (S))); + Next_Discriminant (D); + Next_Elmt (E); + end loop; - R := Range_Expression (Constraint (S)); + -- The Corresponding_Discriminant mechanism is incomplete, because + -- the correspondence between new and old discriminants is not one + -- to one: one new discriminant can constrain several old ones. In + -- that case, scan sequentially the stored_constraint, the list of + -- discriminants of the parents, and the constraints. - -- Capture values of bounds and generate temporaries for them if - -- needed, since checks may cause duplication of the expressions - -- which must not be reevaluated. + -- Previous code checked for the present of the Stored_Constraint + -- list for the derived type, but did not use it at all. Should it + -- be present when the component is a discriminated task type? - -- The forced evaluation removes side effects from expressions, which - -- should occur also in GNATprove mode. Otherwise, we end up with - -- unexpected insertions of actions at places where this is not - -- supposed to occur, e.g. on default parameters of a call. + if Is_Derived_Type (Typ) + and then Scope (Entity (Discrim)) = Etype (Typ) + then + D := First_Discriminant (Etype (Typ)); + E := First_Elmt (Constraints); + while Present (D) loop + if D = Entity (Discrim) then + return Node (E); + end if; - if Expander_Active or GNATprove_Mode then - Force_Evaluation (Low_Bound (R)); - Force_Evaluation (High_Bound (R)); + Next_Discriminant (D); + Next_Elmt (E); + end loop; end if; - elsif Nkind (S) = N_Discriminant_Association then + -- Something is wrong if we did not find the value - -- Syntactically valid in subtype indication + raise Program_Error; + end Get_Discr_Value; - Error_Msg_N ("invalid index constraint", S); - Rewrite (S, New_Occurrence_Of (T, Sloc (S))); - return; + --------------------- + -- Is_Discriminant -- + --------------------- - -- Subtype_Mark case, no anonymous subtypes to construct + function Is_Discriminant (Expr : Node_Id) return Boolean is + Discrim_Scope : Entity_Id; - else - Analyze (S); + begin + if Denotes_Discriminant (Expr) then + Discrim_Scope := Scope (Entity (Expr)); - if Is_Entity_Name (S) then - if not Is_Type (Entity (S)) then - Error_Msg_N ("expect subtype mark for index constraint", S); + -- Either we have a reference to one of Typ's discriminants, - elsif Base_Type (Entity (S)) /= Base_Type (T) then - Wrong_Type (S, Base_Type (T)); + pragma Assert (Discrim_Scope = Typ - -- Check error of subtype with predicate in index constraint + -- or to the discriminants of the parent type, in the case + -- of a derivation of a tagged type with variants. - else - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in index constraint", - S, Entity (S)); - end if; + or else Discrim_Scope = Etype (Typ) + or else Full_View (Discrim_Scope) = Etype (Typ) - return; + -- or same as above for the case where the discriminants + -- were declared in Typ's private view. - else - Error_Msg_N ("invalid index constraint", S); - Rewrite (S, New_Occurrence_Of (T, Sloc (S))); - return; - end if; - end if; + or else (Is_Private_Type (Discrim_Scope) + and then Chars (Discrim_Scope) = Chars (Typ)) - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); + -- or else we are deriving from the full view and the + -- discriminant is declared in the private entity. - Set_Etype (Def_Id, Base_Type (T)); + or else (Is_Private_Type (Typ) + and then Chars (Discrim_Scope) = Chars (Typ)) - if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + -- Or we are constrained the corresponding record of a + -- synchronized type that completes a private declaration. - elsif Is_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + or else (Is_Concurrent_Record_Type (Typ) + and then + Corresponding_Concurrent_Type (Typ) = Discrim_Scope) - else - Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_First_Literal (Def_Id, First_Literal (T)); - end if; + -- or we have a class-wide type, in which case make sure the + -- discriminant found belongs to the root type. - Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + or else (Is_Class_Wide_Type (Typ) + and then Etype (Typ) = Discrim_Scope)); - Set_Scalar_Range (Def_Id, R); + return True; + end if; - Set_Etype (S, Def_Id); - Set_Discrete_RM_Size (Def_Id); - end Constrain_Index; + -- In all other cases we have something wrong - ----------------------- - -- Constrain_Integer -- - ----------------------- + return False; + end Is_Discriminant; - procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); + -- Start of processing for Constrain_Component_Type begin - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + if Nkind (Parent (Comp)) = N_Component_Declaration + and then Comes_From_Source (Parent (Comp)) + and then Comes_From_Source + (Subtype_Indication (Component_Definition (Parent (Comp)))) + and then + Is_Entity_Name + (Subtype_Indication (Component_Definition (Parent (Comp)))) + then + return Compon_Type; + + elsif Is_Array_Type (Compon_Type) then + return Build_Constrained_Array_Type (Compon_Type); + + elsif Has_Discriminants (Compon_Type) then + return Build_Constrained_Discriminated_Type (Compon_Type); + + elsif Is_Access_Type (Compon_Type) then + return Build_Constrained_Access_Type (Compon_Type); - if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); else - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + return Compon_Type; end if; + end Constrain_Component_Type; - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Discrete_RM_Size (Def_Id); - end Constrain_Integer; + -------------------------- + -- Constrain_Concurrent -- + -------------------------- - ------------------------------ - -- Constrain_Ordinary_Fixed -- - ------------------------------ + -- For concurrent types, the associated record value type carries the same + -- discriminants, so when we constrain a concurrent type, we must constrain + -- the corresponding record type as well. - procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : Node_Id; - D : Node_Id; - Rais : Node_Id; + procedure Constrain_Concurrent + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character) + is + -- Retrieve Base_Type to ensure getting to the concurrent type in the + -- case of a private subtype (needed when only doing semantic analysis). + + T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); + T_Val : Entity_Id; begin - Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Small_Value (Def_Id, Small_Value (T)); + if Is_Access_Type (T_Ent) then + T_Ent := Designated_Type (T_Ent); + end if; - -- Process the constraint + T_Val := Corresponding_Record_Type (T_Ent); - C := Constraint (S); + if Present (T_Val) then - -- Delta constraint present + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; - if Nkind (C) = N_Delta_Constraint then + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); - Check_SPARK_05_Restriction ("delta constraint is not allowed", S); - Check_Restriction (No_Obsolescent_Features, C); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Corresponding_Record_Type (Def_Id, + Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); - if Warn_On_Obsolescent_Feature then - Error_Msg_S - ("subtype delta constraint is an " & - "obsolescent feature (RM J.3(7))?j?"); - end if; + else + -- If there is no associated record, expansion is disabled and this + -- is a generic context. Create a subtype in any case, so that + -- semantic analysis can proceed. - D := Delta_Expression (C); - Analyze_And_Resolve (D, Any_Real); - Check_Delta_Expression (D); - Set_Delta_Value (Def_Id, Expr_Value_R (D)); + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; - -- Check that delta value is in range. Obviously we can do this - -- at compile time, but it is strictly a runtime check, and of - -- course there is an ACVC test that checks this. + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + end if; + end Constrain_Concurrent; - if Delta_Value (Def_Id) < Delta_Value (T) then - Error_Msg_N ("??delta value is too small", D); - Rais := - Make_Raise_Constraint_Error (Sloc (D), - Reason => CE_Range_Check_Failed); - Insert_Action (Declaration_Node (Def_Id), Rais); - end if; + ------------------------------------ + -- Constrain_Corresponding_Record -- + ------------------------------------ - C := Range_Constraint (C); + function Constrain_Corresponding_Record + (Prot_Subt : Entity_Id; + Corr_Rec : Entity_Id; + Related_Nod : Node_Id) return Entity_Id + is + T_Sub : constant Entity_Id := + Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); - -- No delta constraint present + begin + Set_Etype (T_Sub, Corr_Rec); + Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); + Set_Is_Constrained (T_Sub, True); + Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); + Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); - else - Set_Delta_Value (Def_Id, Delta_Value (T)); + if Has_Discriminants (Prot_Subt) then -- False only if errors. + Set_Discriminant_Constraint + (T_Sub, Discriminant_Constraint (Prot_Subt)); + Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); + Create_Constrained_Components + (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); end if; - -- Range constraint present - - if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); - -- No range constraint present + if Ekind (Scope (Prot_Subt)) /= E_Record_Type then + Conditional_Delay (T_Sub, Corr_Rec); else - pragma Assert (No (C)); - Set_Scalar_Range (Def_Id, Scalar_Range (T)); + -- This is a component subtype: it will be frozen in the context of + -- the enclosing record's init_proc, so that discriminant references + -- are resolved to discriminals. (Note: we used to skip freezing + -- altogether in that case, which caused errors downstream for + -- components of a bit packed array type). + Set_Has_Delayed_Freeze (T_Sub); end if; - Set_Discrete_RM_Size (Def_Id); - - -- Unconditionally delay the freeze, since we cannot set size - -- information in all cases correctly until the freeze point. - - Set_Has_Delayed_Freeze (Def_Id); - end Constrain_Ordinary_Fixed; + return T_Sub; + end Constrain_Corresponding_Record; ----------------------- - -- Contain_Interface -- + -- Constrain_Decimal -- ----------------------- - function Contain_Interface - (Iface : Entity_Id; - Ifaces : Elist_Id) return Boolean - is - Iface_Elmt : Elmt_Id; + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); + Loc : constant Source_Ptr := Sloc (C); + Range_Expr : Node_Id; + Digits_Expr : Node_Id; + Digits_Val : Uint; + Bound_Val : Ureal; begin - if Present (Ifaces) then - Iface_Elmt := First_Elmt (Ifaces); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; + Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); - Next_Elmt (Iface_Elmt); - end loop; - end if; + if Nkind (C) = N_Range_Constraint then + Range_Expr := Range_Expression (C); + Digits_Val := Digits_Value (T); - return False; - end Contain_Interface; + else + pragma Assert (Nkind (C) = N_Digits_Constraint); - --------------------------- - -- Convert_Scalar_Bounds -- - --------------------------- + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); - procedure Convert_Scalar_Bounds - (N : Node_Id; - Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Loc : Source_Ptr) - is - Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); + Digits_Expr := Digits_Expression (C); + Analyze_And_Resolve (Digits_Expr, Any_Integer); - Lo : Node_Id; - Hi : Node_Id; - Rng : Node_Id; + Check_Digits_Expression (Digits_Expr); + Digits_Val := Expr_Value (Digits_Expr); - begin - -- Defend against previous errors + if Digits_Val > Digits_Value (T) then + Error_Msg_N + ("digits expression is incompatible with subtype", C); + Digits_Val := Digits_Value (T); + end if; - if No (Scalar_Range (Derived_Type)) then - Check_Error_Detected; - return; + if Present (Range_Constraint (C)) then + Range_Expr := Range_Expression (Range_Constraint (C)); + else + Range_Expr := Empty; + end if; end if; - Lo := Build_Scalar_Bound - (Type_Low_Bound (Derived_Type), - Parent_Type, Implicit_Base); - - Hi := Build_Scalar_Bound - (Type_High_Bound (Derived_Type), - Parent_Type, Implicit_Base); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Delta_Value (Def_Id, Delta_Value (T)); + Set_Scale_Value (Def_Id, Scale_Value (T)); + Set_Small_Value (Def_Id, Small_Value (T)); + Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); + Set_Digits_Value (Def_Id, Digits_Val); - Rng := - Make_Range (Loc, - Low_Bound => Lo, - High_Bound => Hi); + -- Manufacture range from given digits value if no range present - Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); + if No (Range_Expr) then + Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); + Range_Expr := + Make_Range (Loc, + Low_Bound => + Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), + High_Bound => + Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); + end if; - Set_Parent (Rng, N); - Set_Scalar_Range (Derived_Type, Rng); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); + Set_Discrete_RM_Size (Def_Id); - -- Analyze the bounds + -- Unconditionally delay the freeze, since we cannot set size + -- information in all cases correctly until the freeze point. - Analyze_And_Resolve (Lo, Implicit_Base); - Analyze_And_Resolve (Hi, Implicit_Base); + Set_Has_Delayed_Freeze (Def_Id); + end Constrain_Decimal; - -- Analyze the range itself, except that we do not analyze it if - -- the bounds are real literals, and we have a fixed-point type. - -- The reason for this is that we delay setting the bounds in this - -- case till we know the final Small and Size values (see circuit - -- in Freeze.Freeze_Fixed_Point_Type for further details). + ---------------------------------- + -- Constrain_Discriminated_Type -- + ---------------------------------- - if Is_Fixed_Point_Type (Parent_Type) - and then Nkind (Lo) = N_Real_Literal - and then Nkind (Hi) = N_Real_Literal - then - return; + procedure Constrain_Discriminated_Type + (Def_Id : Entity_Id; + S : Node_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False) + is + E : constant Entity_Id := Entity (Subtype_Mark (S)); + T : Entity_Id; + C : Node_Id; + Elist : Elist_Id := New_Elmt_List; - -- Here we do the analysis of the range + procedure Fixup_Bad_Constraint; + -- This is called after finding a bad constraint, and after having + -- posted an appropriate error message. The mission is to leave the + -- entity T in as reasonable state as possible. - -- Note: we do this manually, since if we do a normal Analyze and - -- Resolve call, there are problems with the conversions used for - -- the derived type range. + -------------------------- + -- Fixup_Bad_Constraint -- + -------------------------- - else - Set_Etype (Rng, Implicit_Base); - Set_Analyzed (Rng, True); - end if; - end Convert_Scalar_Bounds; + procedure Fixup_Bad_Constraint is + begin + -- Set a reasonable Ekind for the entity. For an incomplete type, + -- we can't do much, but for other types, we can set the proper + -- corresponding subtype kind. - ------------------- - -- Copy_And_Swap -- - ------------------- + if Ekind (T) = E_Incomplete_Type then + Set_Ekind (Def_Id, Ekind (T)); + else + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + end if; - procedure Copy_And_Swap (Priv, Full : Entity_Id) is - begin - -- Initialize new full declaration entity by copying the pertinent - -- fields of the corresponding private declaration entity. + -- Set Etype to the known type, to reduce chances of cascaded errors - -- We temporarily set Ekind to a value appropriate for a type to - -- avoid assert failures in Einfo from checking for setting type - -- attributes on something that is not a type. Ekind (Priv) is an - -- appropriate choice, since it allowed the attributes to be set - -- in the first place. This Ekind value will be modified later. + Set_Etype (Def_Id, E); + Set_Error_Posted (Def_Id); + end Fixup_Bad_Constraint; - Set_Ekind (Full, Ekind (Priv)); + -- Start of processing for Constrain_Discriminated_Type - -- Also set Etype temporarily to Any_Type, again, in the absence - -- of errors, it will be properly reset, and if there are errors, - -- then we want a value of Any_Type to remain. + begin + C := Constraint (S); - Set_Etype (Full, Any_Type); - - -- Now start copying attributes + -- A discriminant constraint is only allowed in a subtype indication, + -- after a subtype mark. This subtype mark must denote either a type + -- with discriminants, or an access type whose designated type is a + -- type with discriminants. A discriminant constraint specifies the + -- values of these discriminants (RM 3.7.2(5)). - Set_Has_Discriminants (Full, Has_Discriminants (Priv)); + T := Base_Type (Entity (Subtype_Mark (S))); - if Has_Discriminants (Full) then - Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); - Set_Stored_Constraint (Full, Stored_Constraint (Priv)); + if Is_Access_Type (T) then + T := Designated_Type (T); end if; - Set_First_Rep_Item (Full, First_Rep_Item (Priv)); - Set_Homonym (Full, Homonym (Priv)); - Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); - Set_Is_Public (Full, Is_Public (Priv)); - Set_Is_Pure (Full, Is_Pure (Priv)); - Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); - Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); - Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); - Set_Has_Pragma_Unreferenced_Objects - (Full, Has_Pragma_Unreferenced_Objects - (Priv)); - - Conditional_Delay (Full, Priv); + -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. + -- Avoid generating an error for access-to-incomplete subtypes. - if Is_Tagged_Type (Full) then - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Priv)); + if Ada_Version >= Ada_2005 + and then Ekind (T) = E_Incomplete_Type + and then Nkind (Parent (S)) = N_Subtype_Declaration + and then not Is_Itype (Def_Id) + then + -- A little sanity check, emit an error message if the type + -- has discriminants to begin with. Type T may be a regular + -- incomplete type or imported via a limited with clause. - if Is_Base_Type (Priv) then - Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); + if Has_Discriminants (T) + or else (From_Limited_With (T) + and then Present (Non_Limited_View (T)) + and then Nkind (Parent (Non_Limited_View (T))) = + N_Full_Type_Declaration + and then Present (Discriminant_Specifications + (Parent (Non_Limited_View (T))))) + then + Error_Msg_N + ("(Ada 2005) incomplete subtype may not be constrained", C); + else + Error_Msg_N ("invalid constraint: type has no discriminant", C); end if; - end if; - Set_Is_Volatile (Full, Is_Volatile (Priv)); - Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); - Set_Scope (Full, Scope (Priv)); - Set_Next_Entity (Full, Next_Entity (Priv)); - Set_First_Entity (Full, First_Entity (Priv)); - Set_Last_Entity (Full, Last_Entity (Priv)); + Fixup_Bad_Constraint; + return; - -- If access types have been recorded for later handling, keep them in - -- the full view so that they get handled when the full view freeze - -- node is expanded. + -- Check that the type has visible discriminants. The type may be + -- a private type with unknown discriminants whose full view has + -- discriminants which are invisible. - if Present (Freeze_Node (Priv)) - and then Present (Access_Types_To_Process (Freeze_Node (Priv))) + elsif not Has_Discriminants (T) + or else + (Has_Unknown_Discriminants (T) + and then Is_Private_Type (T)) then - Ensure_Freeze_Node (Full); - Set_Access_Types_To_Process - (Freeze_Node (Full), - Access_Types_To_Process (Freeze_Node (Priv))); + Error_Msg_N ("invalid constraint: type has no discriminant", C); + Fixup_Bad_Constraint; + return; + + elsif Is_Constrained (E) + or else (Ekind (E) = E_Class_Wide_Subtype + and then Present (Discriminant_Constraint (E))) + then + Error_Msg_N ("type is already constrained", Subtype_Mark (S)); + Fixup_Bad_Constraint; + return; end if; - -- Swap the two entities. Now Private is the full type entity and Full - -- is the private one. They will be swapped back at the end of the - -- private part. This swapping ensures that the entity that is visible - -- in the private part is the full declaration. + -- T may be an unconstrained subtype (e.g. a generic actual). + -- Constraint applies to the base type. - Exchange_Entities (Priv, Full); - Append_Entity (Full, Scope (Full)); - end Copy_And_Swap; + T := Base_Type (T); - ------------------------------------- - -- Copy_Array_Base_Type_Attributes -- - ------------------------------------- + Elist := Build_Discriminant_Constraints (T, S); - procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is - begin - Set_Component_Alignment (T1, Component_Alignment (T2)); - Set_Component_Type (T1, Component_Type (T2)); - Set_Component_Size (T1, Component_Size (T2)); - Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); - Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); - Set_Has_Protected (T1, Has_Protected (T2)); - Set_Has_Task (T1, Has_Task (T2)); - Set_Is_Packed (T1, Is_Packed (T2)); - Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); - Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); - Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); - end Copy_Array_Base_Type_Attributes; + -- If the list returned was empty we had an error in building the + -- discriminant constraint. We have also already signalled an error + -- in the incomplete type case - ----------------------------------- - -- Copy_Array_Subtype_Attributes -- - ----------------------------------- + if Is_Empty_Elmt_List (Elist) then + Fixup_Bad_Constraint; + return; + end if; + + Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); + end Constrain_Discriminated_Type; + + --------------------------- + -- Constrain_Enumeration -- + --------------------------- + + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); - procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is begin - Set_Size_Info (T1, T2); + Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_First_Index (T1, First_Index (T2)); - Set_Is_Aliased (T1, Is_Aliased (T2)); - Set_Is_Volatile (T1, Is_Volatile (T2)); - Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); - Set_Is_Constrained (T1, Is_Constrained (T2)); - Set_Depends_On_Private (T1, Has_Private_Component (T2)); - Set_First_Rep_Item (T1, First_Rep_Item (T2)); - Set_Convention (T1, Convention (T2)); - Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); - Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); - Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); - end Copy_Array_Subtype_Attributes; + Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); - ----------------------------------- - -- Create_Constrained_Components -- - ----------------------------------- + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - procedure Create_Constrained_Components - (Subt : Entity_Id; - Decl_Node : Node_Id; - Typ : Entity_Id; - Constraints : Elist_Id) - is - Loc : constant Source_Ptr := Sloc (Subt); - Comp_List : constant Elist_Id := New_Elmt_List; - Parent_Type : constant Entity_Id := Etype (Typ); - Assoc_List : constant List_Id := New_List; - Discr_Val : Elmt_Id; - Errors : Boolean; - New_C : Entity_Id; - Old_C : Entity_Id; - Is_Static : Boolean := True; + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - procedure Collect_Fixed_Components (Typ : Entity_Id); - -- Collect parent type components that do not appear in a variant part + Set_Discrete_RM_Size (Def_Id); + end Constrain_Enumeration; - procedure Create_All_Components; - -- Iterate over Comp_List to create the components of the subtype + ---------------------- + -- Constrain_Float -- + ---------------------- - function Create_Component (Old_Compon : Entity_Id) return Entity_Id; - -- Creates a new component from Old_Compon, copying all the fields from - -- it, including its Etype, inserts the new component in the Subt entity - -- chain and returns the new component. + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; - function Is_Variant_Record (T : Entity_Id) return Boolean; - -- If true, and discriminants are static, collect only components from - -- variants selected by discriminant values. + begin + Set_Ekind (Def_Id, E_Floating_Point_Subtype); - ------------------------------ - -- Collect_Fixed_Components -- - ------------------------------ + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - procedure Collect_Fixed_Components (Typ : Entity_Id) is - begin - -- Build association list for discriminants, and find components of the - -- variant part selected by the values of the discriminants. + -- Process the constraint - Old_C := First_Discriminant (Typ); - Discr_Val := First_Elmt (Constraints); - while Present (Old_C) loop - Append_To (Assoc_List, - Make_Component_Association (Loc, - Choices => New_List (New_Occurrence_Of (Old_C, Loc)), - Expression => New_Copy (Node (Discr_Val)))); + C := Constraint (S); - Next_Elmt (Discr_Val); - Next_Discriminant (Old_C); - end loop; + -- Digits constraint present - -- The tag and the possible parent component are unconditionally in - -- the subtype. + if Nkind (C) = N_Digits_Constraint then - if Is_Tagged_Type (Typ) - or else Has_Controlled_Component (Typ) - then - Old_C := First_Component (Typ); - while Present (Old_C) loop - if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then - Append_Elmt (Old_C, Comp_List); - end if; + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); + Check_Restriction (No_Obsolescent_Features, C); - Next_Component (Old_C); - end loop; + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("subtype digits constraint is an " & + "obsolescent feature (RM J.3(8))?j?", C); end if; - end Collect_Fixed_Components; - --------------------------- - -- Create_All_Components -- - --------------------------- + D := Digits_Expression (C); + Analyze_And_Resolve (D, Any_Integer); + Check_Digits_Expression (D); + Set_Digits_Value (Def_Id, Expr_Value (D)); - procedure Create_All_Components is - Comp : Elmt_Id; + -- Check that digits value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this. - begin - Comp := First_Elmt (Comp_List); - while Present (Comp) loop - Old_C := Node (Comp); - New_C := Create_Component (Old_C); - - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Subt, Decl_Node, Typ, Constraints)); - Set_Is_Public (New_C, Is_Public (Subt)); + if Digits_Value (Def_Id) > Digits_Value (T) then + Error_Msg_Uint_1 := Digits_Value (T); + Error_Msg_N ("??digits value is too large, maximum is ^", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; - Next_Elmt (Comp); - end loop; - end Create_All_Components; + C := Range_Constraint (C); - ---------------------- - -- Create_Component -- - ---------------------- + -- No digits constraint present - function Create_Component (Old_Compon : Entity_Id) return Entity_Id is - New_Compon : constant Entity_Id := New_Copy (Old_Compon); + else + Set_Digits_Value (Def_Id, Digits_Value (T)); + end if; - begin - if Ekind (Old_Compon) = E_Discriminant - and then Is_Completely_Hidden (Old_Compon) - then - -- This is a shadow discriminant created for a discriminant of - -- the parent type, which needs to be present in the subtype. - -- Give the shadow discriminant an internal name that cannot - -- conflict with that of visible components. + -- Range constraint present - Set_Chars (New_Compon, New_Internal_Name ('C')); - end if; + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - -- Set the parent so we have a proper link for freezing etc. This is - -- not a real parent pointer, since of course our parent does not own - -- up to us and reference us, we are an illegitimate child of the - -- original parent. + -- No range constraint present - Set_Parent (New_Compon, Parent (Old_Compon)); + else + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); + end if; - -- If the old component's Esize was already determined and is a - -- static value, then the new component simply inherits it. Otherwise - -- the old component's size may require run-time determination, but - -- the new component's size still might be statically determinable - -- (if, for example it has a static constraint). In that case we want - -- Layout_Type to recompute the component's size, so we reset its - -- size and positional fields. + Set_Is_Constrained (Def_Id); + end Constrain_Float; - if Frontend_Layout_On_Target - and then not Known_Static_Esize (Old_Compon) - then - Set_Esize (New_Compon, Uint_0); - Init_Normalized_First_Bit (New_Compon); - Init_Normalized_Position (New_Compon); - Init_Normalized_Position_Max (New_Compon); - end if; + --------------------- + -- Constrain_Index -- + --------------------- - -- We do not want this node marked as Comes_From_Source, since - -- otherwise it would get first class status and a separate cross- - -- reference line would be generated. Illegitimate children do not - -- rate such recognition. + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat) + is + Def_Id : Entity_Id; + R : Node_Id := Empty; + T : constant Entity_Id := Etype (Index); - Set_Comes_From_Source (New_Compon, False); + begin + if Nkind (S) = N_Range + or else + (Nkind (S) = N_Attribute_Reference + and then Attribute_Name (S) = Name_Range) + then + -- A Range attribute will be transformed into N_Range by Resolve - -- But it is a real entity, and a birth certificate must be properly - -- registered by entering it into the entity list. + Analyze (S); + Set_Etype (S, T); + R := S; - Enter_Name (New_Compon); + Process_Range_Expr_In_Decl (R, T); - return New_Compon; - end Create_Component; + if not Error_Posted (S) + and then + (Nkind (S) /= N_Range + or else not Covers (T, (Etype (Low_Bound (S)))) + or else not Covers (T, (Etype (High_Bound (S))))) + then + if Base_Type (T) /= Any_Type + and then Etype (Low_Bound (S)) /= Any_Type + and then Etype (High_Bound (S)) /= Any_Type + then + Error_Msg_N ("range expected", S); + end if; + end if; - ----------------------- - -- Is_Variant_Record -- - ----------------------- + elsif Nkind (S) = N_Subtype_Indication then - function Is_Variant_Record (T : Entity_Id) return Boolean is - begin - return Nkind (Parent (T)) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition - and then Present (Component_List (Type_Definition (Parent (T)))) - and then - Present - (Variant_Part (Component_List (Type_Definition (Parent (T))))); - end Is_Variant_Record; + -- The parser has verified that this is a discrete indication - -- Start of processing for Create_Constrained_Components + Resolve_Discrete_Subtype_Indication (S, T); + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (Subtype_Mark (S))); - begin - pragma Assert (Subt /= Base_Type (Subt)); - pragma Assert (Typ = Base_Type (Typ)); + R := Range_Expression (Constraint (S)); - Set_First_Entity (Subt, Empty); - Set_Last_Entity (Subt, Empty); + -- Capture values of bounds and generate temporaries for them if + -- needed, since checks may cause duplication of the expressions + -- which must not be reevaluated. - -- Check whether constraint is fully static, in which case we can - -- optimize the list of components. + -- The forced evaluation removes side effects from expressions, which + -- should occur also in GNATprove mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. - Discr_Val := First_Elmt (Constraints); - while Present (Discr_Val) loop - if not Is_OK_Static_Expression (Node (Discr_Val)) then - Is_Static := False; - exit; + if Expander_Active or GNATprove_Mode then + Force_Evaluation (Low_Bound (R)); + Force_Evaluation (High_Bound (R)); end if; - Next_Elmt (Discr_Val); - end loop; + elsif Nkind (S) = N_Discriminant_Association then - Set_Has_Static_Discriminants (Subt, Is_Static); + -- Syntactically valid in subtype indication - Push_Scope (Subt); + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; - -- Inherit the discriminants of the parent type + -- Subtype_Mark case, no anonymous subtypes to construct - Add_Discriminants : declare - Num_Disc : Int; - Num_Gird : Int; + else + Analyze (S); - begin - Num_Disc := 0; - Old_C := First_Discriminant (Typ); + if Is_Entity_Name (S) then + if not Is_Type (Entity (S)) then + Error_Msg_N ("expect subtype mark for index constraint", S); - while Present (Old_C) loop - Num_Disc := Num_Disc + 1; - New_C := Create_Component (Old_C); - Set_Is_Public (New_C, Is_Public (Subt)); - Next_Discriminant (Old_C); - end loop; + elsif Base_Type (Entity (S)) /= Base_Type (T) then + Wrong_Type (S, Base_Type (T)); - -- For an untagged derived subtype, the number of discriminants may - -- be smaller than the number of inherited discriminants, because - -- several of them may be renamed by a single new discriminant or - -- constrained. In this case, add the hidden discriminants back into - -- the subtype, because they need to be present if the optimizer of - -- the GCC 4.x back-end decides to break apart assignments between - -- objects using the parent view into member-wise assignments. + -- Check error of subtype with predicate in index constraint - Num_Gird := 0; + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (S)); + end if; - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) - then - Old_C := First_Stored_Discriminant (Typ); + return; - while Present (Old_C) loop - Num_Gird := Num_Gird + 1; - Next_Stored_Discriminant (Old_C); - end loop; + else + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; end if; + end if; - if Num_Gird > Num_Disc then - - -- Find out multiple uses of new discriminants, and add hidden - -- components for the extra renamed discriminants. We recognize - -- multiple uses through the Corresponding_Discriminant of a - -- new discriminant: if it constrains several old discriminants, - -- this field points to the last one in the parent type. The - -- stored discriminants of the derived type have the same name - -- as those of the parent. + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); - declare - Constr : Elmt_Id; - New_Discr : Entity_Id; - Old_Discr : Entity_Id; + Set_Etype (Def_Id, Base_Type (T)); - begin - Constr := First_Elmt (Stored_Constraint (Typ)); - Old_Discr := First_Stored_Discriminant (Typ); - while Present (Constr) loop - if Is_Entity_Name (Node (Constr)) - and then Ekind (Entity (Node (Constr))) = E_Discriminant - then - New_Discr := Entity (Node (Constr)); + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); - if Chars (Corresponding_Discriminant (New_Discr)) /= - Chars (Old_Discr) - then - -- The new discriminant has been used to rename a - -- subsequent old discriminant. Introduce a shadow - -- component for the current old discriminant. + elsif Is_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); - New_C := Create_Component (Old_Discr); - Set_Original_Record_Component (New_C, Old_Discr); - end if; + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; - else - -- The constraint has eliminated the old discriminant. - -- Introduce a shadow component. + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - New_C := Create_Component (Old_Discr); - Set_Original_Record_Component (New_C, Old_Discr); - end if; + Set_Scalar_Range (Def_Id, R); - Next_Elmt (Constr); - Next_Stored_Discriminant (Old_Discr); - end loop; - end; - end if; - end Add_Discriminants; + Set_Etype (S, Def_Id); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Index; - if Is_Static - and then Is_Variant_Record (Typ) - then - Collect_Fixed_Components (Typ); + ----------------------- + -- Constrain_Integer -- + ----------------------- - Gather_Components ( - Typ, - Component_List (Type_Definition (Parent (Typ))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); - pragma Assert (not Errors); + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); - Create_All_Components; + begin + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - -- If the subtype declaration is created for a tagged type derivation - -- with constraints, we retrieve the record definition of the parent - -- type to select the components of the proper variant. + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + else + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + end if; - elsif Is_Static - and then Is_Tagged_Type (Typ) - and then Nkind (Parent (Typ)) = N_Full_Type_Declaration - and then - Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition - and then Is_Variant_Record (Parent_Type) - then - Collect_Fixed_Components (Typ); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Integer; - Gather_Components ( - Typ, - Component_List (Type_Definition (Parent (Parent_Type))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); - pragma Assert (not Errors); + ------------------------------ + -- Constrain_Ordinary_Fixed -- + ------------------------------ - -- If the tagged derivation has a type extension, collect all the - -- new components therein. + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; - if Present - (Record_Extension_Part (Type_Definition (Parent (Typ)))) - then - Old_C := First_Component (Typ); - while Present (Old_C) loop - if Original_Record_Component (Old_C) = Old_C - and then Chars (Old_C) /= Name_uTag - and then Chars (Old_C) /= Name_uParent - then - Append_Elmt (Old_C, Comp_List); - end if; + begin + Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Small_Value (Def_Id, Small_Value (T)); - Next_Component (Old_C); - end loop; - end if; + -- Process the constraint - Create_All_Components; + C := Constraint (S); - else - -- If discriminants are not static, or if this is a multi-level type - -- extension, we have to include all components of the parent type. + -- Delta constraint present - Old_C := First_Component (Typ); - while Present (Old_C) loop - New_C := Create_Component (Old_C); + if Nkind (C) = N_Delta_Constraint then - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Subt, Decl_Node, Typ, Constraints)); - Set_Is_Public (New_C, Is_Public (Subt)); + Check_SPARK_05_Restriction ("delta constraint is not allowed", S); + Check_Restriction (No_Obsolescent_Features, C); - Next_Component (Old_C); - end loop; - end if; + if Warn_On_Obsolescent_Feature then + Error_Msg_S + ("subtype delta constraint is an " & + "obsolescent feature (RM J.3(7))?j?"); + end if; - End_Scope; - end Create_Constrained_Components; + D := Delta_Expression (C); + Analyze_And_Resolve (D, Any_Real); + Check_Delta_Expression (D); + Set_Delta_Value (Def_Id, Expr_Value_R (D)); - ------------------------------------------ - -- Decimal_Fixed_Point_Type_Declaration -- - ------------------------------------------ + -- Check that delta value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this. - procedure Decimal_Fixed_Point_Type_Declaration - (T : Entity_Id; - Def : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Def); - Digs_Expr : constant Node_Id := Digits_Expression (Def); - Delta_Expr : constant Node_Id := Delta_Expression (Def); - Implicit_Base : Entity_Id; - Digs_Val : Uint; - Delta_Val : Ureal; - Scale_Val : Uint; - Bound_Val : Ureal; + if Delta_Value (Def_Id) < Delta_Value (T) then + Error_Msg_N ("??delta value is too small", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; - begin - Check_SPARK_05_Restriction - ("decimal fixed point type is not allowed", Def); - Check_Restriction (No_Fixed_Point, Def); + C := Range_Constraint (C); - -- Create implicit base type + -- No delta constraint present - Implicit_Base := - Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); - Set_Etype (Implicit_Base, Implicit_Base); + else + Set_Delta_Value (Def_Id, Delta_Value (T)); + end if; - -- Analyze and process delta expression + -- Range constraint present - Analyze_And_Resolve (Delta_Expr, Universal_Real); + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - Check_Delta_Expression (Delta_Expr); - Delta_Val := Expr_Value_R (Delta_Expr); + -- No range constraint present - -- Check delta is power of 10, and determine scale value from it + else + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); - declare - Val : Ureal; + end if; - begin - Scale_Val := Uint_0; - Val := Delta_Val; + Set_Discrete_RM_Size (Def_Id); - if Val < Ureal_1 then - while Val < Ureal_1 loop - Val := Val * Ureal_10; - Scale_Val := Scale_Val + 1; - end loop; + -- Unconditionally delay the freeze, since we cannot set size + -- information in all cases correctly until the freeze point. - if Scale_Val > 18 then - Error_Msg_N ("scale exceeds maximum value of 18", Def); - Scale_Val := UI_From_Int (+18); - end if; + Set_Has_Delayed_Freeze (Def_Id); + end Constrain_Ordinary_Fixed; - else - while Val > Ureal_1 loop - Val := Val / Ureal_10; - Scale_Val := Scale_Val - 1; - end loop; + ----------------------- + -- Contain_Interface -- + ----------------------- - if Scale_Val < -18 then - Error_Msg_N ("scale is less than minimum value of -18", Def); - Scale_Val := UI_From_Int (-18); + function Contain_Interface + (Iface : Entity_Id; + Ifaces : Elist_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + if Present (Ifaces) then + Iface_Elmt := First_Elmt (Ifaces); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; end if; - end if; - if Val /= Ureal_1 then - Error_Msg_N ("delta expression must be a power of 10", Def); - Delta_Val := Ureal_10 ** (-Scale_Val); - end if; - end; + Next_Elmt (Iface_Elmt); + end loop; + end if; - -- Set delta, scale and small (small = delta for decimal type) + return False; + end Contain_Interface; - Set_Delta_Value (Implicit_Base, Delta_Val); - Set_Scale_Value (Implicit_Base, Scale_Val); - Set_Small_Value (Implicit_Base, Delta_Val); + --------------------------- + -- Convert_Scalar_Bounds -- + --------------------------- - -- Analyze and process digits expression + procedure Convert_Scalar_Bounds + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Loc : Source_Ptr) + is + Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); - Analyze_And_Resolve (Digs_Expr, Any_Integer); - Check_Digits_Expression (Digs_Expr); - Digs_Val := Expr_Value (Digs_Expr); + Lo : Node_Id; + Hi : Node_Id; + Rng : Node_Id; - if Digs_Val > 18 then - Digs_Val := UI_From_Int (+18); - Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); - end if; + begin + -- Defend against previous errors - Set_Digits_Value (Implicit_Base, Digs_Val); - Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; + if No (Scalar_Range (Derived_Type)) then + Check_Error_Detected; + return; + end if; - -- Set range of base type from digits value for now. This will be - -- expanded to represent the true underlying base range by Freeze. + Lo := Build_Scalar_Bound + (Type_Low_Bound (Derived_Type), + Parent_Type, Implicit_Base); - Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); + Hi := Build_Scalar_Bound + (Type_High_Bound (Derived_Type), + Parent_Type, Implicit_Base); - -- Note: We leave size as zero for now, size will be set at freeze - -- time. We have to do this for ordinary fixed-point, because the size - -- depends on the specified small, and we might as well do the same for - -- decimal fixed-point. + Rng := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); - pragma Assert (Esize (Implicit_Base) = Uint_0); + Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); - -- If there are bounds given in the declaration use them as the - -- bounds of the first named subtype. + Set_Parent (Rng, N); + Set_Scalar_Range (Derived_Type, Rng); - if Present (Real_Range_Specification (Def)) then - declare - RRS : constant Node_Id := Real_Range_Specification (Def); - Low : constant Node_Id := Low_Bound (RRS); - High : constant Node_Id := High_Bound (RRS); - Low_Val : Ureal; - High_Val : Ureal; + -- Analyze the bounds - begin - Analyze_And_Resolve (Low, Any_Real); - Analyze_And_Resolve (High, Any_Real); - Check_Real_Bound (Low); - Check_Real_Bound (High); - Low_Val := Expr_Value_R (Low); - High_Val := Expr_Value_R (High); + Analyze_And_Resolve (Lo, Implicit_Base); + Analyze_And_Resolve (Hi, Implicit_Base); - if Low_Val < (-Bound_Val) then - Error_Msg_N - ("range low bound too small for digits value", Low); - Low_Val := -Bound_Val; - end if; + -- Analyze the range itself, except that we do not analyze it if + -- the bounds are real literals, and we have a fixed-point type. + -- The reason for this is that we delay setting the bounds in this + -- case till we know the final Small and Size values (see circuit + -- in Freeze.Freeze_Fixed_Point_Type for further details). - if High_Val > Bound_Val then - Error_Msg_N - ("range high bound too large for digits value", High); - High_Val := Bound_Val; - end if; + if Is_Fixed_Point_Type (Parent_Type) + and then Nkind (Lo) = N_Real_Literal + and then Nkind (Hi) = N_Real_Literal + then + return; - Set_Fixed_Range (T, Loc, Low_Val, High_Val); - end; + -- Here we do the analysis of the range - -- If no explicit range, use range that corresponds to given - -- digits value. This will end up as the final range for the - -- first subtype. + -- Note: we do this manually, since if we do a normal Analyze and + -- Resolve call, there are problems with the conversions used for + -- the derived type range. else - Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); + Set_Etype (Rng, Implicit_Base); + Set_Analyzed (Rng, True); end if; + end Convert_Scalar_Bounds; - -- Complete entity for first subtype - - Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Set_Size_Info (T, Implicit_Base); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); - Set_Delta_Value (T, Delta_Val); - Set_Small_Value (T, Delta_Val); - Set_Scale_Value (T, Scale_Val); - Set_Is_Constrained (T); - end Decimal_Fixed_Point_Type_Declaration; - - ----------------------------------- - -- Derive_Progenitor_Subprograms -- - ----------------------------------- - - procedure Derive_Progenitor_Subprograms - (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id) - is - E : Entity_Id; - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Subp : Entity_Id; - New_Subp : Entity_Id := Empty; - Prim_Elmt : Elmt_Id; - Subp : Entity_Id; - Typ : Entity_Id; + ------------------- + -- Copy_And_Swap -- + ------------------- + procedure Copy_And_Swap (Priv, Full : Entity_Id) is begin - pragma Assert (Ada_Version >= Ada_2005 - and then Is_Record_Type (Tagged_Type) - and then Is_Tagged_Type (Tagged_Type) - and then Has_Interfaces (Tagged_Type)); + -- Initialize new full declaration entity by copying the pertinent + -- fields of the corresponding private declaration entity. - -- Step 1: Transfer to the full-view primitives associated with the - -- partial-view that cover interface primitives. Conceptually this - -- work should be done later by Process_Full_View; done here to - -- simplify its implementation at later stages. It can be safely - -- done here because interfaces must be visible in the partial and - -- private view (RM 7.3(7.3/2)). + -- We temporarily set Ekind to a value appropriate for a type to + -- avoid assert failures in Einfo from checking for setting type + -- attributes on something that is not a type. Ekind (Priv) is an + -- appropriate choice, since it allowed the attributes to be set + -- in the first place. This Ekind value will be modified later. - -- Small optimization: This work is only required if the parent may - -- have entities whose Alias attribute reference an interface primitive. - -- Such a situation may occur if the parent is an abstract type and the - -- primitive has not been yet overridden or if the parent is a generic - -- formal type covering interfaces. + Set_Ekind (Full, Ekind (Priv)); - -- If the tagged type is not abstract, it cannot have abstract - -- primitives (the only entities in the list of primitives of - -- non-abstract tagged types that can reference abstract primitives - -- through its Alias attribute are the internal entities that have - -- attribute Interface_Alias, and these entities are generated later - -- by Add_Internal_Interface_Entities). + -- Also set Etype temporarily to Any_Type, again, in the absence + -- of errors, it will be properly reset, and if there are errors, + -- then we want a value of Any_Type to remain. - if In_Private_Part (Current_Scope) - and then (Is_Abstract_Type (Parent_Type) - or else - Is_Generic_Type (Parent_Type)) - then - Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (Elmt) loop - Subp := Node (Elmt); + Set_Etype (Full, Any_Type); - -- At this stage it is not possible to have entities in the list - -- of primitives that have attribute Interface_Alias. + -- Now start copying attributes - pragma Assert (No (Interface_Alias (Subp))); + Set_Has_Discriminants (Full, Has_Discriminants (Priv)); - Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); + Set_Stored_Constraint (Full, Stored_Constraint (Priv)); + end if; - if Is_Interface (Typ) then - E := Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Subp); + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + Set_Homonym (Full, Homonym (Priv)); + Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); + Set_Is_Public (Full, Is_Public (Priv)); + Set_Is_Pure (Full, Is_Pure (Priv)); + Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); + Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); + Set_Has_Pragma_Unreferenced_Objects + (Full, Has_Pragma_Unreferenced_Objects + (Priv)); - if Present (E) - and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ - then - Replace_Elmt (Elmt, E); - Remove_Homonym (Subp); - end if; - end if; + Conditional_Delay (Full, Priv); - Next_Elmt (Elmt); - end loop; + if Is_Tagged_Type (Full) then + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Priv)); + + if Is_Base_Type (Priv) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); + end if; end if; - -- Step 2: Add primitives of progenitors that are not implemented by - -- parents of Tagged_Type. + Set_Is_Volatile (Full, Is_Volatile (Priv)); + Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); + Set_Scope (Full, Scope (Priv)); + Set_Next_Entity (Full, Next_Entity (Priv)); + Set_First_Entity (Full, First_Entity (Priv)); + Set_Last_Entity (Full, Last_Entity (Priv)); - if Present (Interfaces (Base_Type (Tagged_Type))) then - Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + -- If access types have been recorded for later handling, keep them in + -- the full view so that they get handled when the full view freeze + -- node is expanded. - Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Prim_Elmt) loop - Iface_Subp := Node (Prim_Elmt); + if Present (Freeze_Node (Priv)) + and then Present (Access_Types_To_Process (Freeze_Node (Priv))) + then + Ensure_Freeze_Node (Full); + Set_Access_Types_To_Process + (Freeze_Node (Full), + Access_Types_To_Process (Freeze_Node (Priv))); + end if; - -- Exclude derivation of predefined primitives except those - -- that come from source, or are inherited from one that comes - -- from source. Required to catch declarations of equality - -- operators of interfaces. For example: + -- Swap the two entities. Now Private is the full type entity and Full + -- is the private one. They will be swapped back at the end of the + -- private part. This swapping ensures that the entity that is visible + -- in the private part is the full declaration. - -- type Iface is interface; - -- function "=" (Left, Right : Iface) return Boolean; + Exchange_Entities (Priv, Full); + Append_Entity (Full, Scope (Full)); + end Copy_And_Swap; - if not Is_Predefined_Dispatching_Operation (Iface_Subp) - or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) - then - E := Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Iface_Subp); + ------------------------------------- + -- Copy_Array_Base_Type_Attributes -- + ------------------------------------- - -- If not found we derive a new primitive leaving its alias - -- attribute referencing the interface primitive. + procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is + begin + Set_Component_Alignment (T1, Component_Alignment (T2)); + Set_Component_Type (T1, Component_Type (T2)); + Set_Component_Size (T1, Component_Size (T2)); + Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); + Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); + Set_Has_Protected (T1, Has_Protected (T2)); + Set_Has_Task (T1, Has_Task (T2)); + Set_Is_Packed (T1, Is_Packed (T2)); + Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); + Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); + Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); + end Copy_Array_Base_Type_Attributes; - if No (E) then - Derive_Subprogram - (New_Subp, Iface_Subp, Tagged_Type, Iface); + ----------------------------------- + -- Copy_Array_Subtype_Attributes -- + ----------------------------------- - -- Ada 2012 (AI05-0197): If the covering primitive's name - -- differs from the name of the interface primitive then it - -- is a private primitive inherited from a parent type. In - -- such case, given that Tagged_Type covers the interface, - -- the inherited private primitive becomes visible. For such - -- purpose we add a new entity that renames the inherited - -- private primitive. + procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is + begin + Set_Size_Info (T1, T2); - elsif Chars (E) /= Chars (Iface_Subp) then - pragma Assert (Has_Suffix (E, 'P')); - Derive_Subprogram - (New_Subp, Iface_Subp, Tagged_Type, Iface); - Set_Alias (New_Subp, E); - Set_Is_Abstract_Subprogram (New_Subp, - Is_Abstract_Subprogram (E)); + Set_First_Index (T1, First_Index (T2)); + Set_Is_Aliased (T1, Is_Aliased (T2)); + Set_Is_Volatile (T1, Is_Volatile (T2)); + Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); + Set_Is_Constrained (T1, Is_Constrained (T2)); + Set_Depends_On_Private (T1, Has_Private_Component (T2)); + Set_First_Rep_Item (T1, First_Rep_Item (T2)); + Set_Convention (T1, Convention (T2)); + Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); + Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); + Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); + end Copy_Array_Subtype_Attributes; - -- Propagate to the full view interface entities associated - -- with the partial view. + ----------------------------------- + -- Create_Constrained_Components -- + ----------------------------------- - elsif In_Private_Part (Current_Scope) - and then Present (Alias (E)) - and then Alias (E) = Iface_Subp - and then - List_Containing (Parent (E)) /= - Private_Declarations - (Specification - (Unit_Declaration_Node (Current_Scope))) - then - Append_Elmt (E, Primitive_Operations (Tagged_Type)); - end if; - end if; + procedure Create_Constrained_Components + (Subt : Entity_Id; + Decl_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) + is + Loc : constant Source_Ptr := Sloc (Subt); + Comp_List : constant Elist_Id := New_Elmt_List; + Parent_Type : constant Entity_Id := Etype (Typ); + Assoc_List : constant List_Id := New_List; + Discr_Val : Elmt_Id; + Errors : Boolean; + New_C : Entity_Id; + Old_C : Entity_Id; + Is_Static : Boolean := True; - Next_Elmt (Prim_Elmt); - end loop; + procedure Collect_Fixed_Components (Typ : Entity_Id); + -- Collect parent type components that do not appear in a variant part - Next_Elmt (Iface_Elmt); - end loop; - end if; - end Derive_Progenitor_Subprograms; + procedure Create_All_Components; + -- Iterate over Comp_List to create the components of the subtype - ----------------------- - -- Derive_Subprogram -- - ----------------------- + function Create_Component (Old_Compon : Entity_Id) return Entity_Id; + -- Creates a new component from Old_Compon, copying all the fields from + -- it, including its Etype, inserts the new component in the Subt entity + -- chain and returns the new component. - procedure Derive_Subprogram - (New_Subp : in out Entity_Id; - Parent_Subp : Entity_Id; - Derived_Type : Entity_Id; - Parent_Type : Entity_Id; - Actual_Subp : Entity_Id := Empty) - is - Formal : Entity_Id; - -- Formal parameter of parent primitive operation + function Is_Variant_Record (T : Entity_Id) return Boolean; + -- If true, and discriminants are static, collect only components from + -- variants selected by discriminant values. - Formal_Of_Actual : Entity_Id; - -- Formal parameter of actual operation, when the derivation is to - -- create a renaming for a primitive operation of an actual in an - -- instantiation. + ------------------------------ + -- Collect_Fixed_Components -- + ------------------------------ - New_Formal : Entity_Id; - -- Formal of inherited operation + procedure Collect_Fixed_Components (Typ : Entity_Id) is + begin + -- Build association list for discriminants, and find components of the + -- variant part selected by the values of the discriminants. - Visible_Subp : Entity_Id := Parent_Subp; + Old_C := First_Discriminant (Typ); + Discr_Val := First_Elmt (Constraints); + while Present (Old_C) loop + Append_To (Assoc_List, + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Old_C, Loc)), + Expression => New_Copy (Node (Discr_Val)))); - function Is_Private_Overriding return Boolean; - -- If Subp is a private overriding of a visible operation, the inherited - -- operation derives from the overridden op (even though its body is the - -- overriding one) and the inherited operation is visible now. See - -- sem_disp to see the full details of the handling of the overridden - -- subprogram, which is removed from the list of primitive operations of - -- the type. The overridden subprogram is saved locally in Visible_Subp, - -- and used to diagnose abstract operations that need overriding in the - -- derived type. + Next_Elmt (Discr_Val); + Next_Discriminant (Old_C); + end loop; - procedure Replace_Type (Id, New_Id : Entity_Id); - -- When the type is an anonymous access type, create a new access type - -- designating the derived type. + -- The tag and the possible parent component are unconditionally in + -- the subtype. - procedure Set_Derived_Name; - -- This procedure sets the appropriate Chars name for New_Subp. This - -- is normally just a copy of the parent name. An exception arises for - -- type support subprograms, where the name is changed to reflect the - -- name of the derived type, e.g. if type foo is derived from type bar, - -- then a procedure barDA is derived with a name fooDA. + if Is_Tagged_Type (Typ) + or else Has_Controlled_Component (Typ) + then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then + Append_Elmt (Old_C, Comp_List); + end if; + + Next_Component (Old_C); + end loop; + end if; + end Collect_Fixed_Components; --------------------------- - -- Is_Private_Overriding -- + -- Create_All_Components -- --------------------------- - function Is_Private_Overriding return Boolean is - Prev : Entity_Id; + procedure Create_All_Components is + Comp : Elmt_Id; begin - -- If the parent is not a dispatching operation there is no - -- need to investigate overridings - - if not Is_Dispatching_Operation (Parent_Subp) then - return False; - end if; - - -- The visible operation that is overridden is a homonym of the - -- parent subprogram. We scan the homonym chain to find the one - -- whose alias is the subprogram we are deriving. + Comp := First_Elmt (Comp_List); + while Present (Comp) loop + Old_C := Node (Comp); + New_C := Create_Component (Old_C); - Prev := Current_Entity (Parent_Subp); - while Present (Prev) loop - if Ekind (Prev) = Ekind (Parent_Subp) - and then Alias (Prev) = Parent_Subp - and then Scope (Parent_Subp) = Scope (Prev) - and then not Is_Hidden (Prev) - then - Visible_Subp := Prev; - return True; - end if; + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); - Prev := Homonym (Prev); + Next_Elmt (Comp); end loop; + end Create_All_Components; - return False; - end Is_Private_Overriding; - - ------------------ - -- Replace_Type -- - ------------------ + ---------------------- + -- Create_Component -- + ---------------------- - procedure Replace_Type (Id, New_Id : Entity_Id) is - Id_Type : constant Entity_Id := Etype (Id); - Acc_Type : Entity_Id; - Par : constant Node_Id := Parent (Derived_Type); + function Create_Component (Old_Compon : Entity_Id) return Entity_Id is + New_Compon : constant Entity_Id := New_Copy (Old_Compon); begin - -- When the type is an anonymous access type, create a new access - -- type designating the derived type. This itype must be elaborated - -- at the point of the derivation, not on subsequent calls that may - -- be out of the proper scope for Gigi, so we insert a reference to - -- it after the derivation. - - if Ekind (Id_Type) = E_Anonymous_Access_Type then - declare - Desig_Typ : Entity_Id := Designated_Type (Id_Type); + if Ekind (Old_Compon) = E_Discriminant + and then Is_Completely_Hidden (Old_Compon) + then + -- This is a shadow discriminant created for a discriminant of + -- the parent type, which needs to be present in the subtype. + -- Give the shadow discriminant an internal name that cannot + -- conflict with that of visible components. - begin - if Ekind (Desig_Typ) = E_Record_Type_With_Private - and then Present (Full_View (Desig_Typ)) - and then not Is_Private_Type (Parent_Type) - then - Desig_Typ := Full_View (Desig_Typ); - end if; + Set_Chars (New_Compon, New_Internal_Name ('C')); + end if; - if Base_Type (Desig_Typ) = Base_Type (Parent_Type) + -- Set the parent so we have a proper link for freezing etc. This is + -- not a real parent pointer, since of course our parent does not own + -- up to us and reference us, we are an illegitimate child of the + -- original parent. - -- Ada 2005 (AI-251): Handle also derivations of abstract - -- interface primitives. + Set_Parent (New_Compon, Parent (Old_Compon)); - or else (Is_Interface (Desig_Typ) - and then not Is_Class_Wide_Type (Desig_Typ)) - then - Acc_Type := New_Copy (Id_Type); - Set_Etype (Acc_Type, Acc_Type); - Set_Scope (Acc_Type, New_Subp); - - -- Set size of anonymous access type. If we have an access - -- to an unconstrained array, this is a fat pointer, so it - -- is sizes at twice addtress size. + -- If the old component's Esize was already determined and is a + -- static value, then the new component simply inherits it. Otherwise + -- the old component's size may require run-time determination, but + -- the new component's size still might be statically determinable + -- (if, for example it has a static constraint). In that case we want + -- Layout_Type to recompute the component's size, so we reset its + -- size and positional fields. - if Is_Array_Type (Desig_Typ) - and then not Is_Constrained (Desig_Typ) - then - Init_Size (Acc_Type, 2 * System_Address_Size); + if Frontend_Layout_On_Target + and then not Known_Static_Esize (Old_Compon) + then + Set_Esize (New_Compon, Uint_0); + Init_Normalized_First_Bit (New_Compon); + Init_Normalized_Position (New_Compon); + Init_Normalized_Position_Max (New_Compon); + end if; - -- Other cases use a thin pointer + -- We do not want this node marked as Comes_From_Source, since + -- otherwise it would get first class status and a separate cross- + -- reference line would be generated. Illegitimate children do not + -- rate such recognition. - else - Init_Size (Acc_Type, System_Address_Size); - end if; + Set_Comes_From_Source (New_Compon, False); - -- Set remaining characterstics of anonymous access type + -- But it is a real entity, and a birth certificate must be properly + -- registered by entering it into the entity list. - Init_Alignment (Acc_Type); - Set_Directly_Designated_Type (Acc_Type, Derived_Type); + Enter_Name (New_Compon); - Set_Etype (New_Id, Acc_Type); - Set_Scope (New_Id, New_Subp); + return New_Compon; + end Create_Component; - -- Create a reference to it + ----------------------- + -- Is_Variant_Record -- + ----------------------- - Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); + function Is_Variant_Record (T : Entity_Id) return Boolean is + begin + return Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition + and then Present (Component_List (Type_Definition (Parent (T)))) + and then + Present + (Variant_Part (Component_List (Type_Definition (Parent (T))))); + end Is_Variant_Record; - else - Set_Etype (New_Id, Id_Type); - end if; - end; + -- Start of processing for Create_Constrained_Components - -- In Ada2012, a formal may have an incomplete type but the type - -- derivation that inherits the primitive follows the full view. + begin + pragma Assert (Subt /= Base_Type (Subt)); + pragma Assert (Typ = Base_Type (Typ)); - elsif Base_Type (Id_Type) = Base_Type (Parent_Type) - or else - (Ekind (Id_Type) = E_Record_Type_With_Private - and then Present (Full_View (Id_Type)) - and then - Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) - or else - (Ada_Version >= Ada_2012 - and then Ekind (Id_Type) = E_Incomplete_Type - and then Full_View (Id_Type) = Parent_Type) - then - -- Constraint checks on formals are generated during expansion, - -- based on the signature of the original subprogram. The bounds - -- of the derived type are not relevant, and thus we can use - -- the base type for the formals. However, the return type may be - -- used in a context that requires that the proper static bounds - -- be used (a case statement, for example) and for those cases - -- we must use the derived type (first subtype), not its base. + Set_First_Entity (Subt, Empty); + Set_Last_Entity (Subt, Empty); - -- If the derived_type_definition has no constraints, we know that - -- the derived type has the same constraints as the first subtype - -- of the parent, and we can also use it rather than its base, - -- which can lead to more efficient code. + -- Check whether constraint is fully static, in which case we can + -- optimize the list of components. - if Etype (Id) = Parent_Type then - if Is_Scalar_Type (Parent_Type) - and then - Subtypes_Statically_Compatible (Parent_Type, Derived_Type) - then - Set_Etype (New_Id, Derived_Type); + Discr_Val := First_Elmt (Constraints); + while Present (Discr_Val) loop + if not Is_OK_Static_Expression (Node (Discr_Val)) then + Is_Static := False; + exit; + end if; - elsif Nkind (Par) = N_Full_Type_Declaration - and then - Nkind (Type_Definition (Par)) = N_Derived_Type_Definition - and then - Is_Entity_Name - (Subtype_Indication (Type_Definition (Par))) - then - Set_Etype (New_Id, Derived_Type); + Next_Elmt (Discr_Val); + end loop; - else - Set_Etype (New_Id, Base_Type (Derived_Type)); - end if; + Set_Has_Static_Discriminants (Subt, Is_Static); - else - Set_Etype (New_Id, Base_Type (Derived_Type)); - end if; + Push_Scope (Subt); - else - Set_Etype (New_Id, Etype (Id)); - end if; - end Replace_Type; + -- Inherit the discriminants of the parent type - ---------------------- - -- Set_Derived_Name -- - ---------------------- + Add_Discriminants : declare + Num_Disc : Int; + Num_Gird : Int; - procedure Set_Derived_Name is - Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); begin - if Nm = TSS_Null then - Set_Chars (New_Subp, Chars (Parent_Subp)); - else - Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); - end if; - end Set_Derived_Name; - - -- Start of processing for Derive_Subprogram - - begin - New_Subp := - New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); - Set_Ekind (New_Subp, Ekind (Parent_Subp)); - Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); + Num_Disc := 0; + Old_C := First_Discriminant (Typ); - -- Check whether the inherited subprogram is a private operation that - -- should be inherited but not yet made visible. Such subprograms can - -- become visible at a later point (e.g., the private part of a public - -- child unit) via Declare_Inherited_Private_Subprograms. If the - -- following predicate is true, then this is not such a private - -- operation and the subprogram simply inherits the name of the parent - -- subprogram. Note the special check for the names of controlled - -- operations, which are currently exempted from being inherited with - -- a hidden name because they must be findable for generation of - -- implicit run-time calls. + while Present (Old_C) loop + Num_Disc := Num_Disc + 1; + New_C := Create_Component (Old_C); + Set_Is_Public (New_C, Is_Public (Subt)); + Next_Discriminant (Old_C); + end loop; - if not Is_Hidden (Parent_Subp) - or else Is_Internal (Parent_Subp) - or else Is_Private_Overriding - or else Is_Internal_Name (Chars (Parent_Subp)) - or else Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) - then - Set_Derived_Name; + -- For an untagged derived subtype, the number of discriminants may + -- be smaller than the number of inherited discriminants, because + -- several of them may be renamed by a single new discriminant or + -- constrained. In this case, add the hidden discriminants back into + -- the subtype, because they need to be present if the optimizer of + -- the GCC 4.x back-end decides to break apart assignments between + -- objects using the parent view into member-wise assignments. - -- An inherited dispatching equality will be overridden by an internally - -- generated one, or by an explicit one, so preserve its name and thus - -- its entry in the dispatch table. Otherwise, if Parent_Subp is a - -- private operation it may become invisible if the full view has - -- progenitors, and the dispatch table will be malformed. - -- We check that the type is limited to handle the anomalous declaration - -- of Limited_Controlled, which is derived from a non-limited type, and - -- which is handled specially elsewhere as well. + Num_Gird := 0; - elsif Chars (Parent_Subp) = Name_Op_Eq - and then Is_Dispatching_Operation (Parent_Subp) - and then Etype (Parent_Subp) = Standard_Boolean - and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) - and then - Etype (First_Formal (Parent_Subp)) = - Etype (Next_Formal (First_Formal (Parent_Subp))) - then - Set_Derived_Name; + if Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + Old_C := First_Stored_Discriminant (Typ); - -- If parent is hidden, this can be a regular derivation if the - -- parent is immediately visible in a non-instantiating context, - -- or if we are in the private part of an instance. This test - -- should still be refined ??? + while Present (Old_C) loop + Num_Gird := Num_Gird + 1; + Next_Stored_Discriminant (Old_C); + end loop; + end if; - -- The test for In_Instance_Not_Visible avoids inheriting the derived - -- operation as a non-visible operation in cases where the parent - -- subprogram might not be visible now, but was visible within the - -- original generic, so it would be wrong to make the inherited - -- subprogram non-visible now. (Not clear if this test is fully - -- correct; are there any cases where we should declare the inherited - -- operation as not visible to avoid it being overridden, e.g., when - -- the parent type is a generic actual with private primitives ???) + if Num_Gird > Num_Disc then - -- (they should be treated the same as other private inherited - -- subprograms, but it's not clear how to do this cleanly). ??? + -- Find out multiple uses of new discriminants, and add hidden + -- components for the extra renamed discriminants. We recognize + -- multiple uses through the Corresponding_Discriminant of a + -- new discriminant: if it constrains several old discriminants, + -- this field points to the last one in the parent type. The + -- stored discriminants of the derived type have the same name + -- as those of the parent. - elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) - and then Is_Immediately_Visible (Parent_Subp) - and then not In_Instance) - or else In_Instance_Not_Visible - then - Set_Derived_Name; + declare + Constr : Elmt_Id; + New_Discr : Entity_Id; + Old_Discr : Entity_Id; - -- Ada 2005 (AI-251): Regular derivation if the parent subprogram - -- overrides an interface primitive because interface primitives - -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) + begin + Constr := First_Elmt (Stored_Constraint (Typ)); + Old_Discr := First_Stored_Discriminant (Typ); + while Present (Constr) loop + if Is_Entity_Name (Node (Constr)) + and then Ekind (Entity (Node (Constr))) = E_Discriminant + then + New_Discr := Entity (Node (Constr)); - elsif Ada_Version >= Ada_2005 - and then Is_Dispatching_Operation (Parent_Subp) - and then Covers_Some_Interface (Parent_Subp) - then - Set_Derived_Name; + if Chars (Corresponding_Discriminant (New_Discr)) /= + Chars (Old_Discr) + then + -- The new discriminant has been used to rename a + -- subsequent old discriminant. Introduce a shadow + -- component for the current old discriminant. - -- Otherwise, the type is inheriting a private operation, so enter - -- it with a special name so it can't be overridden. + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; - else - Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); - end if; + else + -- The constraint has eliminated the old discriminant. + -- Introduce a shadow component. - Set_Parent (New_Subp, Parent (Derived_Type)); + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; - if Present (Actual_Subp) then - Replace_Type (Actual_Subp, New_Subp); - else - Replace_Type (Parent_Subp, New_Subp); - end if; + Next_Elmt (Constr); + Next_Stored_Discriminant (Old_Discr); + end loop; + end; + end if; + end Add_Discriminants; - Conditional_Delay (New_Subp, Parent_Subp); + if Is_Static + and then Is_Variant_Record (Typ) + then + Collect_Fixed_Components (Typ); - -- If we are creating a renaming for a primitive operation of an - -- actual of a generic derived type, we must examine the signature - -- of the actual primitive, not that of the generic formal, which for - -- example may be an interface. However the name and initial value - -- of the inherited operation are those of the formal primitive. + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Typ))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); - Formal := First_Formal (Parent_Subp); + Create_All_Components; - if Present (Actual_Subp) then - Formal_Of_Actual := First_Formal (Actual_Subp); - else - Formal_Of_Actual := Empty; - end if; + -- If the subtype declaration is created for a tagged type derivation + -- with constraints, we retrieve the record definition of the parent + -- type to select the components of the proper variant. - while Present (Formal) loop - New_Formal := New_Copy (Formal); + elsif Is_Static + and then Is_Tagged_Type (Typ) + and then Nkind (Parent (Typ)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition + and then Is_Variant_Record (Parent_Type) + then + Collect_Fixed_Components (Typ); - -- Normally we do not go copying parents, but in the case of - -- formals, we need to link up to the declaration (which is the - -- parameter specification), and it is fine to link up to the - -- original formal's parameter specification in this case. + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Parent_Type))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); - Set_Parent (New_Formal, Parent (Formal)); - Append_Entity (New_Formal, New_Subp); + -- If the tagged derivation has a type extension, collect all the + -- new components therein. - if Present (Formal_Of_Actual) then - Replace_Type (Formal_Of_Actual, New_Formal); - Next_Formal (Formal_Of_Actual); - else - Replace_Type (Formal, New_Formal); - end if; + if Present + (Record_Extension_Part (Type_Definition (Parent (Typ)))) + then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Original_Record_Component (Old_C) = Old_C + and then Chars (Old_C) /= Name_uTag + and then Chars (Old_C) /= Name_uParent + then + Append_Elmt (Old_C, Comp_List); + end if; - Next_Formal (Formal); - end loop; + Next_Component (Old_C); + end loop; + end if; - -- If this derivation corresponds to a tagged generic actual, then - -- primitive operations rename those of the actual. Otherwise the - -- primitive operations rename those of the parent type, If the parent - -- renames an intrinsic operator, so does the new subprogram. We except - -- concatenation, which is always properly typed, and does not get - -- expanded as other intrinsic operations. + Create_All_Components; - if No (Actual_Subp) then - if Is_Intrinsic_Subprogram (Parent_Subp) then - Set_Is_Intrinsic_Subprogram (New_Subp); + else + -- If discriminants are not static, or if this is a multi-level type + -- extension, we have to include all components of the parent type. - if Present (Alias (Parent_Subp)) - and then Chars (Parent_Subp) /= Name_Op_Concat - then - Set_Alias (New_Subp, Alias (Parent_Subp)); - else - Set_Alias (New_Subp, Parent_Subp); - end if; + Old_C := First_Component (Typ); + while Present (Old_C) loop + New_C := Create_Component (Old_C); - else - Set_Alias (New_Subp, Parent_Subp); - end if; + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); - else - Set_Alias (New_Subp, Actual_Subp); + Next_Component (Old_C); + end loop; end if; - -- Derived subprograms of a tagged type must inherit the convention - -- of the parent subprogram (a requirement of AI-117). Derived - -- subprograms of untagged types simply get convention Ada by default. + End_Scope; + end Create_Constrained_Components; - -- If the derived type is a tagged generic formal type with unknown - -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). + ------------------------------------------ + -- Decimal_Fixed_Point_Type_Declaration -- + ------------------------------------------ - -- However, if the type is derived from a generic formal, the further - -- inherited subprogram has the convention of the non-generic ancestor. - -- Otherwise there would be no way to override the operation. - -- (This is subject to forthcoming ARG discussions). + procedure Decimal_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Digs_Expr : constant Node_Id := Digits_Expression (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + Implicit_Base : Entity_Id; + Digs_Val : Uint; + Delta_Val : Ureal; + Scale_Val : Uint; + Bound_Val : Ureal; - if Is_Tagged_Type (Derived_Type) then - if Is_Generic_Type (Derived_Type) - and then Has_Unknown_Discriminants (Derived_Type) - then - Set_Convention (New_Subp, Convention_Intrinsic); + begin + Check_SPARK_05_Restriction + ("decimal fixed point type is not allowed", Def); + Check_Restriction (No_Fixed_Point, Def); - else - if Is_Generic_Type (Parent_Type) - and then Has_Unknown_Discriminants (Parent_Type) - then - Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); - else - Set_Convention (New_Subp, Convention (Parent_Subp)); - end if; - end if; - end if; + -- Create implicit base type - -- Predefined controlled operations retain their name even if the parent - -- is hidden (see above), but they are not primitive operations if the - -- ancestor is not visible, for example if the parent is a private - -- extension completed with a controlled extension. Note that a full - -- type that is controlled can break privacy: the flag Is_Controlled is - -- set on both views of the type. + Implicit_Base := + Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); - if Is_Controlled (Parent_Type) - and then Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) - and then Is_Hidden (Parent_Subp) - and then not Is_Visibly_Controlled (Parent_Type) - then - Set_Is_Hidden (New_Subp); - end if; + -- Analyze and process delta expression - Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); - Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); + Analyze_And_Resolve (Delta_Expr, Universal_Real); - if Ekind (Parent_Subp) = E_Procedure then - Set_Is_Valued_Procedure - (New_Subp, Is_Valued_Procedure (Parent_Subp)); - else - Set_Has_Controlling_Result - (New_Subp, Has_Controlling_Result (Parent_Subp)); - end if; + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); - -- 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. + -- Check delta is power of 10, and determine scale value from it - Set_No_Return (New_Subp, No_Return (Parent_Subp)); + declare + Val : Ureal; - -- 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 - -- instantiation time. If the derivation is for a generic actual, the - -- function is not abstract unless the actual is. + begin + Scale_Val := Uint_0; + Val := Delta_Val; - if Is_Generic_Type (Derived_Type) - and then not Is_Abstract_Type (Derived_Type) - then - null; + if Val < Ureal_1 then + while Val < Ureal_1 loop + Val := Val * Ureal_10; + Scale_Val := Scale_Val + 1; + end loop; - -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" - -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + if Scale_Val > 18 then + Error_Msg_N ("scale exceeds maximum value of 18", Def); + Scale_Val := UI_From_Int (+18); + end if; - elsif Ada_Version >= Ada_2005 - and then (Is_Abstract_Subprogram (Alias (New_Subp)) - or else (Is_Tagged_Type (Derived_Type) - and then Etype (New_Subp) = Derived_Type - and then not Is_Null_Extension (Derived_Type)) - or else (Is_Tagged_Type (Derived_Type) - and then Ekind (Etype (New_Subp)) = - E_Anonymous_Access_Type - and then Designated_Type (Etype (New_Subp)) = - Derived_Type - and then not Is_Null_Extension (Derived_Type))) - and then No (Actual_Subp) - then - if not Is_Tagged_Type (Derived_Type) - or else Is_Abstract_Type (Derived_Type) - or else Is_Abstract_Subprogram (Alias (New_Subp)) - then - Set_Is_Abstract_Subprogram (New_Subp); else - Set_Requires_Overriding (New_Subp); - end if; + while Val > Ureal_1 loop + Val := Val / Ureal_10; + Scale_Val := Scale_Val - 1; + end loop; - elsif Ada_Version < Ada_2005 - and then (Is_Abstract_Subprogram (Alias (New_Subp)) - or else (Is_Tagged_Type (Derived_Type) - and then Etype (New_Subp) = Derived_Type - and then No (Actual_Subp))) - then - Set_Is_Abstract_Subprogram (New_Subp); + if Scale_Val < -18 then + Error_Msg_N ("scale is less than minimum value of -18", Def); + Scale_Val := UI_From_Int (-18); + end if; + end if; - -- AI05-0097 : an inherited operation that dispatches on result is - -- abstract if the derived type is abstract, even if the parent type - -- is concrete and the derived type is a null extension. + if Val /= Ureal_1 then + Error_Msg_N ("delta expression must be a power of 10", Def); + Delta_Val := Ureal_10 ** (-Scale_Val); + end if; + end; - elsif Has_Controlling_Result (Alias (New_Subp)) - and then Is_Abstract_Type (Etype (New_Subp)) - then - Set_Is_Abstract_Subprogram (New_Subp); + -- Set delta, scale and small (small = delta for decimal type) - -- Finally, if the parent type is abstract we must verify that all - -- inherited operations are either non-abstract or overridden, or that - -- the derived type itself is abstract (this check is performed at the - -- end of a package declaration, in Check_Abstract_Overriding). A - -- private overriding in the parent type will not be visible in the - -- derivation if we are not in an inner package or in a child unit of - -- the parent type, in which case the abstractness of the inherited - -- operation is carried to the new subprogram. + Set_Delta_Value (Implicit_Base, Delta_Val); + Set_Scale_Value (Implicit_Base, Scale_Val); + Set_Small_Value (Implicit_Base, Delta_Val); - elsif Is_Abstract_Type (Parent_Type) - and then not In_Open_Scopes (Scope (Parent_Type)) - and then Is_Private_Overriding - and then Is_Abstract_Subprogram (Visible_Subp) - then - if No (Actual_Subp) then - Set_Alias (New_Subp, Visible_Subp); - Set_Is_Abstract_Subprogram (New_Subp, True); + -- Analyze and process digits expression - else - -- If this is a derivation for an instance of a formal derived - -- type, abstractness comes from the primitive operation of the - -- actual, not from the operation inherited from the ancestor. + Analyze_And_Resolve (Digs_Expr, Any_Integer); + Check_Digits_Expression (Digs_Expr); + Digs_Val := Expr_Value (Digs_Expr); - Set_Is_Abstract_Subprogram - (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); - end if; + if Digs_Val > 18 then + Digs_Val := UI_From_Int (+18); + Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); end if; - New_Overloaded_Entity (New_Subp, Derived_Type); + Set_Digits_Value (Implicit_Base, Digs_Val); + Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; - -- Check for case of a derived subprogram for the instantiation of a - -- formal derived tagged type, if so mark the subprogram as dispatching - -- and inherit the dispatching attributes of the actual subprogram. The - -- derived subprogram is effectively renaming of the actual subprogram, - -- so it needs to have the same attributes as the actual. + -- Set range of base type from digits value for now. This will be + -- expanded to represent the true underlying base range by Freeze. - if Present (Actual_Subp) - and then Is_Dispatching_Operation (Actual_Subp) - then - Set_Is_Dispatching_Operation (New_Subp); + Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); - if Present (DTC_Entity (Actual_Subp)) then - Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); - Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); - end if; - end if; + -- Note: We leave size as zero for now, size will be set at freeze + -- time. We have to do this for ordinary fixed-point, because the size + -- depends on the specified small, and we might as well do the same for + -- decimal fixed-point. - -- Indicate that a derived subprogram does not require a body and that - -- it does not require processing of default expressions. + pragma Assert (Esize (Implicit_Base) = Uint_0); - Set_Has_Completion (New_Subp); - Set_Default_Expressions_Processed (New_Subp); + -- If there are bounds given in the declaration use them as the + -- bounds of the first named subtype. - if Ekind (New_Subp) = E_Function then - Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); - end if; - end Derive_Subprogram; + if Present (Real_Range_Specification (Def)) then + declare + RRS : constant Node_Id := Real_Range_Specification (Def); + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); + Low_Val : Ureal; + High_Val : Ureal; - ------------------------ - -- Derive_Subprograms -- - ------------------------ + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); - procedure Derive_Subprograms - (Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Generic_Actual : Entity_Id := Empty) - is - Op_List : constant Elist_Id := - Collect_Primitive_Operations (Parent_Type); + if Low_Val < (-Bound_Val) then + Error_Msg_N + ("range low bound too small for digits value", Low); + Low_Val := -Bound_Val; + end if; - function Check_Derived_Type return Boolean; - -- Check that all the entities derived from Parent_Type are found in - -- the list of primitives of Derived_Type exactly in the same order. + if High_Val > Bound_Val then + Error_Msg_N + ("range high bound too large for digits value", High); + High_Val := Bound_Val; + end if; - procedure Derive_Interface_Subprogram - (New_Subp : in out Entity_Id; - Subp : Entity_Id; - Actual_Subp : Entity_Id); - -- Derive New_Subp from the ultimate alias of the parent subprogram Subp - -- (which is an interface primitive). If Generic_Actual is present then - -- Actual_Subp is the actual subprogram corresponding with the generic - -- subprogram Subp. + Set_Fixed_Range (T, Loc, Low_Val, High_Val); + end; - function Check_Derived_Type return Boolean is - E : Entity_Id; - Elmt : Elmt_Id; - List : Elist_Id; - New_Subp : Entity_Id; - Op_Elmt : Elmt_Id; - Subp : Entity_Id; + -- If no explicit range, use range that corresponds to given + -- digits value. This will end up as the final range for the + -- first subtype. - begin - -- Traverse list of entities in the current scope searching for - -- an incomplete type whose full-view is derived type + else + Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); + end if; - E := First_Entity (Scope (Derived_Type)); - while Present (E) and then E /= Derived_Type loop - if Ekind (E) = E_Incomplete_Type - and then Present (Full_View (E)) - and then Full_View (E) = Derived_Type - then - -- Disable this test if Derived_Type completes an incomplete - -- type because in such case more primitives can be added - -- later to the list of primitives of Derived_Type by routine - -- Process_Incomplete_Dependents + -- Complete entity for first subtype - return True; - end if; + Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + Set_Delta_Value (T, Delta_Val); + Set_Small_Value (T, Delta_Val); + Set_Scale_Value (T, Scale_Val); + Set_Is_Constrained (T); + end Decimal_Fixed_Point_Type_Declaration; - E := Next_Entity (E); - end loop; + ----------------------------------- + -- Derive_Progenitor_Subprograms -- + ----------------------------------- - List := Collect_Primitive_Operations (Derived_Type); - Elmt := First_Elmt (List); + procedure Derive_Progenitor_Subprograms + (Parent_Type : Entity_Id; + Tagged_Type : Entity_Id) + is + E : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Subp : Entity_Id; + New_Subp : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Typ : Entity_Id; - Op_Elmt := First_Elmt (Op_List); - while Present (Op_Elmt) loop - Subp := Node (Op_Elmt); - New_Subp := Node (Elmt); + begin + pragma Assert (Ada_Version >= Ada_2005 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type)); - -- At this early stage Derived_Type has no entities with attribute - -- Interface_Alias. In addition, such primitives are always - -- located at the end of the list of primitives of Parent_Type. - -- Therefore, if found we can safely stop processing pending - -- entities. + -- Step 1: Transfer to the full-view primitives associated with the + -- partial-view that cover interface primitives. Conceptually this + -- work should be done later by Process_Full_View; done here to + -- simplify its implementation at later stages. It can be safely + -- done here because interfaces must be visible in the partial and + -- private view (RM 7.3(7.3/2)). - exit when Present (Interface_Alias (Subp)); + -- Small optimization: This work is only required if the parent may + -- have entities whose Alias attribute reference an interface primitive. + -- Such a situation may occur if the parent is an abstract type and the + -- primitive has not been yet overridden or if the parent is a generic + -- formal type covering interfaces. - -- Handle hidden entities + -- If the tagged type is not abstract, it cannot have abstract + -- primitives (the only entities in the list of primitives of + -- non-abstract tagged types that can reference abstract primitives + -- through its Alias attribute are the internal entities that have + -- attribute Interface_Alias, and these entities are generated later + -- by Add_Internal_Interface_Entities). - if not Is_Predefined_Dispatching_Operation (Subp) - and then Is_Hidden (Subp) - then - if Present (New_Subp) - and then Primitive_Names_Match (Subp, New_Subp) - then - Next_Elmt (Elmt); - end if; + if In_Private_Part (Current_Scope) + and then (Is_Abstract_Type (Parent_Type) + or else + Is_Generic_Type (Parent_Type)) + then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Subp := Node (Elmt); - else - if not Present (New_Subp) - or else Ekind (Subp) /= Ekind (New_Subp) - or else not Primitive_Names_Match (Subp, New_Subp) + -- At this stage it is not possible to have entities in the list + -- of primitives that have attribute Interface_Alias. + + pragma Assert (No (Interface_Alias (Subp))); + + Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); + + if Is_Interface (Typ) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Subp); + + if Present (E) + and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ then - return False; + Replace_Elmt (Elmt, E); + Remove_Homonym (Subp); end if; - - Next_Elmt (Elmt); end if; - Next_Elmt (Op_Elmt); + Next_Elmt (Elmt); end loop; + end if; - return True; - end Check_Derived_Type; + -- Step 2: Add primitives of progenitors that are not implemented by + -- parents of Tagged_Type. - --------------------------------- - -- Derive_Interface_Subprogram -- - --------------------------------- + if Present (Interfaces (Base_Type (Tagged_Type))) then + Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - procedure Derive_Interface_Subprogram - (New_Subp : in out Entity_Id; - Subp : Entity_Id; - Actual_Subp : Entity_Id) - is - Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); - Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); + Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Prim_Elmt) loop + Iface_Subp := Node (Prim_Elmt); - begin - pragma Assert (Is_Interface (Iface_Type)); + -- Exclude derivation of predefined primitives except those + -- that come from source, or are inherited from one that comes + -- from source. Required to catch declarations of equality + -- operators of interfaces. For example: - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Iface_Subp, - Derived_Type => Derived_Type, - Parent_Type => Iface_Type, - Actual_Subp => Actual_Subp); + -- type Iface is interface; + -- function "=" (Left, Right : Iface) return Boolean; - -- Given that this new interface entity corresponds with a primitive - -- of the parent that was not overridden we must leave it associated - -- with its parent primitive to ensure that it will share the same - -- dispatch table slot when overridden. + if not Is_Predefined_Dispatching_Operation (Iface_Subp) + or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) + then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Subp); - if No (Actual_Subp) then - Set_Alias (New_Subp, Subp); + -- If not found we derive a new primitive leaving its alias + -- attribute referencing the interface primitive. - -- For instantiations this is not needed since the previous call to - -- Derive_Subprogram leaves the entity well decorated. + if No (E) then + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); - else - pragma Assert (Alias (New_Subp) = Actual_Subp); - null; - end if; - end Derive_Interface_Subprogram; + -- Ada 2012 (AI05-0197): If the covering primitive's name + -- differs from the name of the interface primitive then it + -- is a private primitive inherited from a parent type. In + -- such case, given that Tagged_Type covers the interface, + -- the inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. - -- Local variables + elsif Chars (E) /= Chars (Iface_Subp) then + pragma Assert (Has_Suffix (E, 'P')); + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + Set_Alias (New_Subp, E); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (E)); - Alias_Subp : Entity_Id; - Act_List : Elist_Id; - Act_Elmt : Elmt_Id; - Act_Subp : Entity_Id := Empty; - Elmt : Elmt_Id; - Need_Search : Boolean := False; - New_Subp : Entity_Id := Empty; - Parent_Base : Entity_Id; - Subp : Entity_Id; + -- Propagate to the full view interface entities associated + -- with the partial view. - -- Start of processing for Derive_Subprograms + elsif In_Private_Part (Current_Scope) + and then Present (Alias (E)) + and then Alias (E) = Iface_Subp + and then + List_Containing (Parent (E)) /= + Private_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope))) + then + Append_Elmt (E, Primitive_Operations (Tagged_Type)); + end if; + end if; - begin - if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Has_Discriminants (Parent_Type) - and then Present (Full_View (Parent_Type)) - then - Parent_Base := Full_View (Parent_Type); - else - Parent_Base := Parent_Type; - end if; + Next_Elmt (Prim_Elmt); + end loop; - if Present (Generic_Actual) then - Act_List := Collect_Primitive_Operations (Generic_Actual); - Act_Elmt := First_Elmt (Act_List); - else - Act_List := No_Elist; - Act_Elmt := No_Elmt; + Next_Elmt (Iface_Elmt); + end loop; end if; + end Derive_Progenitor_Subprograms; - -- Derive primitives inherited from the parent. Note that if the generic - -- actual is present, this is not really a type derivation, it is a - -- completion within an instance. - - -- Case 1: Derived_Type does not implement interfaces + ----------------------- + -- Derive_Subprogram -- + ----------------------- - if not Is_Tagged_Type (Derived_Type) - or else (not Has_Interfaces (Derived_Type) - and then not (Present (Generic_Actual) - and then Has_Interfaces (Generic_Actual))) - then - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); + procedure Derive_Subprogram + (New_Subp : in out Entity_Id; + Parent_Subp : Entity_Id; + Derived_Type : Entity_Id; + Parent_Type : Entity_Id; + Actual_Subp : Entity_Id := Empty) + is + Formal : Entity_Id; + -- Formal parameter of parent primitive operation - -- Literals are derived earlier in the process of building the - -- derived type, and are skipped here. + Formal_Of_Actual : Entity_Id; + -- Formal parameter of actual operation, when the derivation is to + -- create a renaming for a primitive operation of an actual in an + -- instantiation. - if Ekind (Subp) = E_Enumeration_Literal then - null; + New_Formal : Entity_Id; + -- Formal of inherited operation - -- The actual is a direct descendant and the common primitive - -- operations appear in the same order. + Visible_Subp : Entity_Id := Parent_Subp; - -- If the generic parent type is present, the derived type is an - -- instance of a formal derived type, and within the instance its - -- operations are those of the actual. We derive from the formal - -- type but make the inherited operations aliases of the - -- corresponding operations of the actual. + function Is_Private_Overriding return Boolean; + -- If Subp is a private overriding of a visible operation, the inherited + -- operation derives from the overridden op (even though its body is the + -- overriding one) and the inherited operation is visible now. See + -- sem_disp to see the full details of the handling of the overridden + -- subprogram, which is removed from the list of primitive operations of + -- the type. The overridden subprogram is saved locally in Visible_Subp, + -- and used to diagnose abstract operations that need overriding in the + -- derived type. - else - pragma Assert (No (Node (Act_Elmt)) - or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) - and then - Type_Conformant - (Subp, Node (Act_Elmt), - Skip_Controlling_Formals => True))); + procedure Replace_Type (Id, New_Id : Entity_Id); + -- When the type is an anonymous access type, create a new access type + -- designating the derived type. - Derive_Subprogram - (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + procedure Set_Derived_Name; + -- This procedure sets the appropriate Chars name for New_Subp. This + -- is normally just a copy of the parent name. An exception arises for + -- type support subprograms, where the name is changed to reflect the + -- name of the derived type, e.g. if type foo is derived from type bar, + -- then a procedure barDA is derived with a name fooDA. - if Present (Act_Elmt) then - Next_Elmt (Act_Elmt); - end if; - end if; + --------------------------- + -- Is_Private_Overriding -- + --------------------------- - Next_Elmt (Elmt); - end loop; + function Is_Private_Overriding return Boolean is + Prev : Entity_Id; - -- Case 2: Derived_Type implements interfaces + begin + -- If the parent is not a dispatching operation there is no + -- need to investigate overridings - else - -- If the parent type has no predefined primitives we remove - -- predefined primitives from the list of primitives of generic - -- actual to simplify the complexity of this algorithm. + if not Is_Dispatching_Operation (Parent_Subp) then + return False; + end if; - if Present (Generic_Actual) then - declare - Has_Predefined_Primitives : Boolean := False; + -- The visible operation that is overridden is a homonym of the + -- parent subprogram. We scan the homonym chain to find the one + -- whose alias is the subprogram we are deriving. - begin - -- Check if the parent type has predefined primitives - - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); - - if Is_Predefined_Dispatching_Operation (Subp) - and then not Comes_From_Source (Ultimate_Alias (Subp)) - then - Has_Predefined_Primitives := True; - exit; - end if; + Prev := Current_Entity (Parent_Subp); + while Present (Prev) loop + if Ekind (Prev) = Ekind (Parent_Subp) + and then Alias (Prev) = Parent_Subp + and then Scope (Parent_Subp) = Scope (Prev) + and then not Is_Hidden (Prev) + then + Visible_Subp := Prev; + return True; + end if; - Next_Elmt (Elmt); - end loop; + Prev := Homonym (Prev); + end loop; - -- Remove predefined primitives of Generic_Actual. We must use - -- an auxiliary list because in case of tagged types the value - -- returned by Collect_Primitive_Operations is the value stored - -- in its Primitive_Operations attribute (and we don't want to - -- modify its current contents). + return False; + end Is_Private_Overriding; - if not Has_Predefined_Primitives then - declare - Aux_List : constant Elist_Id := New_Elmt_List; + ------------------ + -- Replace_Type -- + ------------------ - begin - Elmt := First_Elmt (Act_List); - while Present (Elmt) loop - Subp := Node (Elmt); + procedure Replace_Type (Id, New_Id : Entity_Id) is + Id_Type : constant Entity_Id := Etype (Id); + Acc_Type : Entity_Id; + Par : constant Node_Id := Parent (Derived_Type); - if not Is_Predefined_Dispatching_Operation (Subp) - or else Comes_From_Source (Subp) - then - Append_Elmt (Subp, Aux_List); - end if; + begin + -- When the type is an anonymous access type, create a new access + -- type designating the derived type. This itype must be elaborated + -- at the point of the derivation, not on subsequent calls that may + -- be out of the proper scope for Gigi, so we insert a reference to + -- it after the derivation. - Next_Elmt (Elmt); - end loop; + if Ekind (Id_Type) = E_Anonymous_Access_Type then + declare + Desig_Typ : Entity_Id := Designated_Type (Id_Type); - Act_List := Aux_List; - end; + begin + if Ekind (Desig_Typ) = E_Record_Type_With_Private + and then Present (Full_View (Desig_Typ)) + and then not Is_Private_Type (Parent_Type) + then + Desig_Typ := Full_View (Desig_Typ); end if; - Act_Elmt := First_Elmt (Act_List); - Act_Subp := Node (Act_Elmt); - end; - end if; + if Base_Type (Desig_Typ) = Base_Type (Parent_Type) - -- Stage 1: If the generic actual is not present we derive the - -- primitives inherited from the parent type. If the generic parent - -- type is present, the derived type is an instance of a formal - -- derived type, and within the instance its operations are those of - -- the actual. We derive from the formal type but make the inherited - -- operations aliases of the corresponding operations of the actual. + -- Ada 2005 (AI-251): Handle also derivations of abstract + -- interface primitives. - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); - Alias_Subp := Ultimate_Alias (Subp); + or else (Is_Interface (Desig_Typ) + and then not Is_Class_Wide_Type (Desig_Typ)) + then + Acc_Type := New_Copy (Id_Type); + Set_Etype (Acc_Type, Acc_Type); + Set_Scope (Acc_Type, New_Subp); - -- Do not derive internal entities of the parent that link - -- interface primitives with their covering primitive. These - -- entities will be added to this type when frozen. + -- Set size of anonymous access type. If we have an access + -- to an unconstrained array, this is a fat pointer, so it + -- is sizes at twice addtress size. - if Present (Interface_Alias (Subp)) then - goto Continue; - end if; + if Is_Array_Type (Desig_Typ) + and then not Is_Constrained (Desig_Typ) + then + Init_Size (Acc_Type, 2 * System_Address_Size); - -- If the generic actual is present find the corresponding - -- operation in the generic actual. If the parent type is a - -- direct ancestor of the derived type then, even if it is an - -- interface, the operations are inherited from the primary - -- dispatch table and are in the proper order. If we detect here - -- that primitives are not in the same order we traverse the list - -- of primitive operations of the actual to find the one that - -- implements the interface primitive. + -- Other cases use a thin pointer - if Need_Search - or else - (Present (Generic_Actual) - and then Present (Act_Subp) - and then not - (Primitive_Names_Match (Subp, Act_Subp) - and then - Type_Conformant (Subp, Act_Subp, - Skip_Controlling_Formals => True))) - then - pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, - Use_Full_View => True)); + else + Init_Size (Acc_Type, System_Address_Size); + end if; - -- Remember that we need searching for all pending primitives + -- Set remaining characterstics of anonymous access type - Need_Search := True; + Init_Alignment (Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Derived_Type); - -- Handle entities associated with interface primitives + Set_Etype (New_Id, Acc_Type); + Set_Scope (New_Id, New_Subp); - if Present (Alias_Subp) - and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) - and then not Is_Predefined_Dispatching_Operation (Subp) - then - -- Search for the primitive in the homonym chain + -- Create a reference to it - Act_Subp := - Find_Primitive_Covering_Interface - (Tagged_Type => Generic_Actual, - Iface_Prim => Alias_Subp); + Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); - -- Previous search may not locate primitives covering - -- interfaces defined in generics units or instantiations. - -- (it fails if the covering primitive has formals whose - -- type is also defined in generics or instantiations). - -- In such case we search in the list of primitives of the - -- generic actual for the internal entity that links the - -- interface primitive and the covering primitive. + else + Set_Etype (New_Id, Id_Type); + end if; + end; - if No (Act_Subp) - and then Is_Generic_Type (Parent_Type) - then - -- This code has been designed to handle only generic - -- formals that implement interfaces that are defined - -- in a generic unit or instantiation. If this code is - -- needed for other cases we must review it because - -- (given that it relies on Original_Location to locate - -- the primitive of Generic_Actual that covers the - -- interface) it could leave linked through attribute - -- Alias entities of unrelated instantiations). + -- In Ada2012, a formal may have an incomplete type but the type + -- derivation that inherits the primitive follows the full view. - pragma Assert - (Is_Generic_Unit - (Scope (Find_Dispatching_Type (Alias_Subp))) - or else - Instantiation_Depth - (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); + elsif Base_Type (Id_Type) = Base_Type (Parent_Type) + or else + (Ekind (Id_Type) = E_Record_Type_With_Private + and then Present (Full_View (Id_Type)) + and then + Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) + or else + (Ada_Version >= Ada_2012 + and then Ekind (Id_Type) = E_Incomplete_Type + and then Full_View (Id_Type) = Parent_Type) + then + -- Constraint checks on formals are generated during expansion, + -- based on the signature of the original subprogram. The bounds + -- of the derived type are not relevant, and thus we can use + -- the base type for the formals. However, the return type may be + -- used in a context that requires that the proper static bounds + -- be used (a case statement, for example) and for those cases + -- we must use the derived type (first subtype), not its base. - declare - Iface_Prim_Loc : constant Source_Ptr := - Original_Location (Sloc (Alias_Subp)); + -- If the derived_type_definition has no constraints, we know that + -- the derived type has the same constraints as the first subtype + -- of the parent, and we can also use it rather than its base, + -- which can lead to more efficient code. - Elmt : Elmt_Id; - Prim : Entity_Id; + if Etype (Id) = Parent_Type then + if Is_Scalar_Type (Parent_Type) + and then + Subtypes_Statically_Compatible (Parent_Type, Derived_Type) + then + Set_Etype (New_Id, Derived_Type); - begin - Elmt := - First_Elmt (Primitive_Operations (Generic_Actual)); + elsif Nkind (Par) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Par)) = N_Derived_Type_Definition + and then + Is_Entity_Name + (Subtype_Indication (Type_Definition (Par))) + then + Set_Etype (New_Id, Derived_Type); - Search : while Present (Elmt) loop - Prim := Node (Elmt); + else + Set_Etype (New_Id, Base_Type (Derived_Type)); + end if; - if Present (Interface_Alias (Prim)) - and then Original_Location - (Sloc (Interface_Alias (Prim))) = - Iface_Prim_Loc - then - Act_Subp := Alias (Prim); - exit Search; - end if; + else + Set_Etype (New_Id, Base_Type (Derived_Type)); + end if; - Next_Elmt (Elmt); - end loop Search; - end; - end if; + else + Set_Etype (New_Id, Etype (Id)); + end if; + end Replace_Type; - pragma Assert (Present (Act_Subp) - or else Is_Abstract_Type (Generic_Actual) - or else Serious_Errors_Detected > 0); + ---------------------- + -- Set_Derived_Name -- + ---------------------- - -- Handle predefined primitives plus the rest of user-defined - -- primitives + procedure Set_Derived_Name is + Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); + begin + if Nm = TSS_Null then + Set_Chars (New_Subp, Chars (Parent_Subp)); + else + Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); + end if; + end Set_Derived_Name; - else - Act_Elmt := First_Elmt (Act_List); - while Present (Act_Elmt) loop - Act_Subp := Node (Act_Elmt); + -- Start of processing for Derive_Subprogram - exit when Primitive_Names_Match (Subp, Act_Subp) - and then Type_Conformant - (Subp, Act_Subp, - Skip_Controlling_Formals => True) - and then No (Interface_Alias (Act_Subp)); + begin + New_Subp := + New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); + Set_Ekind (New_Subp, Ekind (Parent_Subp)); + Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); - Next_Elmt (Act_Elmt); - end loop; + -- Check whether the inherited subprogram is a private operation that + -- should be inherited but not yet made visible. Such subprograms can + -- become visible at a later point (e.g., the private part of a public + -- child unit) via Declare_Inherited_Private_Subprograms. If the + -- following predicate is true, then this is not such a private + -- operation and the subprogram simply inherits the name of the parent + -- subprogram. Note the special check for the names of controlled + -- operations, which are currently exempted from being inherited with + -- a hidden name because they must be findable for generation of + -- implicit run-time calls. - if No (Act_Elmt) then - Act_Subp := Empty; - end if; - end if; - end if; + if not Is_Hidden (Parent_Subp) + or else Is_Internal (Parent_Subp) + or else Is_Private_Overriding + or else Is_Internal_Name (Chars (Parent_Subp)) + or else Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) + then + Set_Derived_Name; - -- Case 1: If the parent is a limited interface then it has the - -- predefined primitives of synchronized interfaces. However, the - -- actual type may be a non-limited type and hence it does not - -- have such primitives. + -- An inherited dispatching equality will be overridden by an internally + -- generated one, or by an explicit one, so preserve its name and thus + -- its entry in the dispatch table. Otherwise, if Parent_Subp is a + -- private operation it may become invisible if the full view has + -- progenitors, and the dispatch table will be malformed. + -- We check that the type is limited to handle the anomalous declaration + -- of Limited_Controlled, which is derived from a non-limited type, and + -- which is handled specially elsewhere as well. - if Present (Generic_Actual) - and then not Present (Act_Subp) - and then Is_Limited_Interface (Parent_Base) - and then Is_Predefined_Interface_Primitive (Subp) + elsif Chars (Parent_Subp) = Name_Op_Eq + and then Is_Dispatching_Operation (Parent_Subp) + and then Etype (Parent_Subp) = Standard_Boolean + and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) + and then + Etype (First_Formal (Parent_Subp)) = + Etype (Next_Formal (First_Formal (Parent_Subp))) + then + Set_Derived_Name; + + -- If parent is hidden, this can be a regular derivation if the + -- parent is immediately visible in a non-instantiating context, + -- or if we are in the private part of an instance. This test + -- should still be refined ??? + + -- The test for In_Instance_Not_Visible avoids inheriting the derived + -- operation as a non-visible operation in cases where the parent + -- subprogram might not be visible now, but was visible within the + -- original generic, so it would be wrong to make the inherited + -- subprogram non-visible now. (Not clear if this test is fully + -- correct; are there any cases where we should declare the inherited + -- operation as not visible to avoid it being overridden, e.g., when + -- the parent type is a generic actual with private primitives ???) + + -- (they should be treated the same as other private inherited + -- subprograms, but it's not clear how to do this cleanly). ??? + + elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) + and then Is_Immediately_Visible (Parent_Subp) + and then not In_Instance) + or else In_Instance_Not_Visible + then + Set_Derived_Name; + + -- Ada 2005 (AI-251): Regular derivation if the parent subprogram + -- overrides an interface primitive because interface primitives + -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) + + elsif Ada_Version >= Ada_2005 + and then Is_Dispatching_Operation (Parent_Subp) + and then Covers_Some_Interface (Parent_Subp) + then + Set_Derived_Name; + + -- Otherwise, the type is inheriting a private operation, so enter + -- it with a special name so it can't be overridden. + + else + Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); + end if; + + Set_Parent (New_Subp, Parent (Derived_Type)); + + if Present (Actual_Subp) then + Replace_Type (Actual_Subp, New_Subp); + else + Replace_Type (Parent_Subp, New_Subp); + end if; + + Conditional_Delay (New_Subp, Parent_Subp); + + -- If we are creating a renaming for a primitive operation of an + -- actual of a generic derived type, we must examine the signature + -- of the actual primitive, not that of the generic formal, which for + -- example may be an interface. However the name and initial value + -- of the inherited operation are those of the formal primitive. + + Formal := First_Formal (Parent_Subp); + + if Present (Actual_Subp) then + Formal_Of_Actual := First_Formal (Actual_Subp); + else + Formal_Of_Actual := Empty; + end if; + + while Present (Formal) loop + New_Formal := New_Copy (Formal); + + -- Normally we do not go copying parents, but in the case of + -- formals, we need to link up to the declaration (which is the + -- parameter specification), and it is fine to link up to the + -- original formal's parameter specification in this case. + + Set_Parent (New_Formal, Parent (Formal)); + Append_Entity (New_Formal, New_Subp); + + if Present (Formal_Of_Actual) then + Replace_Type (Formal_Of_Actual, New_Formal); + Next_Formal (Formal_Of_Actual); + else + Replace_Type (Formal, New_Formal); + end if; + + Next_Formal (Formal); + end loop; + + -- If this derivation corresponds to a tagged generic actual, then + -- primitive operations rename those of the actual. Otherwise the + -- primitive operations rename those of the parent type, If the parent + -- renames an intrinsic operator, so does the new subprogram. We except + -- concatenation, which is always properly typed, and does not get + -- expanded as other intrinsic operations. + + if No (Actual_Subp) then + if Is_Intrinsic_Subprogram (Parent_Subp) then + Set_Is_Intrinsic_Subprogram (New_Subp); + + if Present (Alias (Parent_Subp)) + and then Chars (Parent_Subp) /= Name_Op_Concat then - null; + Set_Alias (New_Subp, Alias (Parent_Subp)); + else + Set_Alias (New_Subp, Parent_Subp); + end if; - -- Case 2: Inherit entities associated with interfaces that were - -- not covered by the parent type. We exclude here null interface - -- primitives because they do not need special management. + else + Set_Alias (New_Subp, Parent_Subp); + end if; - -- We also exclude interface operations that are renamings. If the - -- subprogram is an explicit renaming of an interface primitive, - -- it is a regular primitive operation, and the presence of its - -- alias is not relevant: it has to be derived like any other - -- primitive. + else + Set_Alias (New_Subp, Actual_Subp); + end if; - elsif Present (Alias (Subp)) - and then Nkind (Unit_Declaration_Node (Subp)) /= - N_Subprogram_Renaming_Declaration - and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) - and then not - (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification - and then Null_Present (Parent (Alias_Subp))) + -- Derived subprograms of a tagged type must inherit the convention + -- of the parent subprogram (a requirement of AI-117). Derived + -- subprograms of untagged types simply get convention Ada by default. + + -- If the derived type is a tagged generic formal type with unknown + -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). + + -- However, if the type is derived from a generic formal, the further + -- inherited subprogram has the convention of the non-generic ancestor. + -- Otherwise there would be no way to override the operation. + -- (This is subject to forthcoming ARG discussions). + + if Is_Tagged_Type (Derived_Type) then + if Is_Generic_Type (Derived_Type) + and then Has_Unknown_Discriminants (Derived_Type) + then + Set_Convention (New_Subp, Convention_Intrinsic); + + else + if Is_Generic_Type (Parent_Type) + and then Has_Unknown_Discriminants (Parent_Type) then - -- If this is an abstract private type then we transfer the - -- derivation of the interface primitive from the partial view - -- to the full view. This is safe because all the interfaces - -- must be visible in the partial view. Done to avoid adding - -- a new interface derivation to the private part of the - -- enclosing package; otherwise this new derivation would be - -- decorated as hidden when the analysis of the enclosing - -- package completes. + Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); + else + Set_Convention (New_Subp, Convention (Parent_Subp)); + end if; + end if; + end if; - if Is_Abstract_Type (Derived_Type) - and then In_Private_Part (Current_Scope) - and then Has_Private_Declaration (Derived_Type) - then - declare - Partial_View : Entity_Id; - Elmt : Elmt_Id; - Ent : Entity_Id; + -- Predefined controlled operations retain their name even if the parent + -- is hidden (see above), but they are not primitive operations if the + -- ancestor is not visible, for example if the parent is a private + -- extension completed with a controlled extension. Note that a full + -- type that is controlled can break privacy: the flag Is_Controlled is + -- set on both views of the type. - begin - Partial_View := First_Entity (Current_Scope); - loop - exit when No (Partial_View) - or else (Has_Private_Declaration (Partial_View) - and then - Full_View (Partial_View) = Derived_Type); + if Is_Controlled (Parent_Type) + and then Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) + and then Is_Hidden (Parent_Subp) + and then not Is_Visibly_Controlled (Parent_Type) + then + Set_Is_Hidden (New_Subp); + end if; - Next_Entity (Partial_View); - end loop; + Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); + Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); - -- If the partial view was not found then the source code - -- has errors and the derivation is not needed. + if Ekind (Parent_Subp) = E_Procedure then + Set_Is_Valued_Procedure + (New_Subp, Is_Valued_Procedure (Parent_Subp)); + else + Set_Has_Controlling_Result + (New_Subp, Has_Controlling_Result (Parent_Subp)); + end if; - if Present (Partial_View) then - Elmt := - First_Elmt (Primitive_Operations (Partial_View)); - while Present (Elmt) loop - Ent := Node (Elmt); + -- 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. - if Present (Alias (Ent)) - and then Ultimate_Alias (Ent) = Alias (Subp) - then - Append_Elmt - (Ent, Primitive_Operations (Derived_Type)); - exit; - end if; + Set_No_Return (New_Subp, No_Return (Parent_Subp)); - Next_Elmt (Elmt); - end loop; + -- 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 + -- instantiation time. If the derivation is for a generic actual, the + -- function is not abstract unless the actual is. - -- If the interface primitive was not found in the - -- partial view then this interface primitive was - -- overridden. We add a derivation to activate in - -- Derive_Progenitor_Subprograms the machinery to - -- search for it. + if Is_Generic_Type (Derived_Type) + and then not Is_Abstract_Type (Derived_Type) + then + null; - if No (Elmt) then - Derive_Interface_Subprogram - (New_Subp => New_Subp, - Subp => Subp, - Actual_Subp => Act_Subp); - end if; - end if; - end; - else - Derive_Interface_Subprogram - (New_Subp => New_Subp, - Subp => Subp, - Actual_Subp => Act_Subp); - end if; + -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" + -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + + elsif Ada_Version >= Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then not Is_Null_Extension (Derived_Type)) + or else (Is_Tagged_Type (Derived_Type) + and then Ekind (Etype (New_Subp)) = + E_Anonymous_Access_Type + and then Designated_Type (Etype (New_Subp)) = + Derived_Type + and then not Is_Null_Extension (Derived_Type))) + and then No (Actual_Subp) + then + if not Is_Tagged_Type (Derived_Type) + or else Is_Abstract_Type (Derived_Type) + or else Is_Abstract_Subprogram (Alias (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + else + Set_Requires_Overriding (New_Subp); + end if; - -- Case 3: Common derivation + elsif Ada_Version < Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then No (Actual_Subp))) + then + Set_Is_Abstract_Subprogram (New_Subp); - else - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Subp, - Derived_Type => Derived_Type, - Parent_Type => Parent_Base, - Actual_Subp => Act_Subp); - end if; + -- AI05-0097 : an inherited operation that dispatches on result is + -- abstract if the derived type is abstract, even if the parent type + -- is concrete and the derived type is a null extension. - -- No need to update Act_Elm if we must search for the - -- corresponding operation in the generic actual + elsif Has_Controlling_Result (Alias (New_Subp)) + and then Is_Abstract_Type (Etype (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); - if not Need_Search - and then Present (Act_Elmt) - then - Next_Elmt (Act_Elmt); - Act_Subp := Node (Act_Elmt); - end if; + -- Finally, if the parent type is abstract we must verify that all + -- inherited operations are either non-abstract or overridden, or that + -- the derived type itself is abstract (this check is performed at the + -- end of a package declaration, in Check_Abstract_Overriding). A + -- private overriding in the parent type will not be visible in the + -- derivation if we are not in an inner package or in a child unit of + -- the parent type, in which case the abstractness of the inherited + -- operation is carried to the new subprogram. - <> - Next_Elmt (Elmt); - end loop; + elsif Is_Abstract_Type (Parent_Type) + and then not In_Open_Scopes (Scope (Parent_Type)) + and then Is_Private_Overriding + and then Is_Abstract_Subprogram (Visible_Subp) + then + if No (Actual_Subp) then + Set_Alias (New_Subp, Visible_Subp); + Set_Is_Abstract_Subprogram (New_Subp, True); - -- Inherit additional operations from progenitors. If the derived - -- type is a generic actual, there are not new primitive operations - -- for the type because it has those of the actual, and therefore - -- nothing needs to be done. The renamings generated above are not - -- primitive operations, and their purpose is simply to make the - -- proper operations visible within an instantiation. + else + -- If this is a derivation for an instance of a formal derived + -- type, abstractness comes from the primitive operation of the + -- actual, not from the operation inherited from the ancestor. - if No (Generic_Actual) then - Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); end if; end if; - -- Final check: Direct descendants must have their primitives in the - -- same order. We exclude from this test untagged types and instances - -- of formal derived types. We skip this test if we have already - -- reported serious errors in the sources. + New_Overloaded_Entity (New_Subp, Derived_Type); - pragma Assert (not Is_Tagged_Type (Derived_Type) - or else Present (Generic_Actual) - or else Serious_Errors_Detected > 0 - or else Check_Derived_Type); - end Derive_Subprograms; + -- Check for case of a derived subprogram for the instantiation of a + -- formal derived tagged type, if so mark the subprogram as dispatching + -- and inherit the dispatching attributes of the actual subprogram. The + -- derived subprogram is effectively renaming of the actual subprogram, + -- so it needs to have the same attributes as the actual. - -------------------------------- - -- Derived_Standard_Character -- - -------------------------------- + if Present (Actual_Subp) + and then Is_Dispatching_Operation (Actual_Subp) + then + Set_Is_Dispatching_Operation (New_Subp); - procedure Derived_Standard_Character - (N : Node_Id; - Parent_Type : Entity_Id; - Derived_Type : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Def : constant Node_Id := Type_Definition (N); - Indic : constant Node_Id := Subtype_Indication (Def); - Parent_Base : constant Entity_Id := Base_Type (Parent_Type); - Implicit_Base : constant Entity_Id := - Create_Itype - (E_Enumeration_Type, N, Derived_Type, 'B'); + if Present (DTC_Entity (Actual_Subp)) then + Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); + Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); + end if; + end if; - Lo : Node_Id; - Hi : Node_Id; + -- Indicate that a derived subprogram does not require a body and that + -- it does not require processing of default expressions. - begin - Discard_Node (Process_Subtype (Indic, N)); + Set_Has_Completion (New_Subp); + Set_Default_Expressions_Processed (New_Subp); - Set_Etype (Implicit_Base, Parent_Base); - Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); - Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); + if Ekind (New_Subp) = E_Function then + Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); + end if; + end Derive_Subprogram; - Set_Is_Character_Type (Implicit_Base, True); - Set_Has_Delayed_Freeze (Implicit_Base); + ------------------------ + -- Derive_Subprograms -- + ------------------------ - -- The bounds of the implicit base are the bounds of the parent base. - -- Note that their type is the parent base. + procedure Derive_Subprograms + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty) + is + Op_List : constant Elist_Id := + Collect_Primitive_Operations (Parent_Type); - Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); - Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); + function Check_Derived_Type return Boolean; + -- Check that all the entities derived from Parent_Type are found in + -- the list of primitives of Derived_Type exactly in the same order. - Set_Scalar_Range (Implicit_Base, - Make_Range (Loc, - Low_Bound => Lo, - High_Bound => Hi)); + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id); + -- Derive New_Subp from the ultimate alias of the parent subprogram Subp + -- (which is an interface primitive). If Generic_Actual is present then + -- Actual_Subp is the actual subprogram corresponding with the generic + -- subprogram Subp. - Conditional_Delay (Derived_Type, Parent_Type); + function Check_Derived_Type return Boolean is + E : Entity_Id; + Elmt : Elmt_Id; + List : Elist_Id; + New_Subp : Entity_Id; + Op_Elmt : Elmt_Id; + Subp : Entity_Id; - Set_Ekind (Derived_Type, E_Enumeration_Subtype); - Set_Etype (Derived_Type, Implicit_Base); - Set_Size_Info (Derived_Type, Parent_Type); + begin + -- Traverse list of entities in the current scope searching for + -- an incomplete type whose full-view is derived type - if Unknown_RM_Size (Derived_Type) then - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); - end if; + E := First_Entity (Scope (Derived_Type)); + while Present (E) and then E /= Derived_Type loop + if Ekind (E) = E_Incomplete_Type + and then Present (Full_View (E)) + and then Full_View (E) = Derived_Type + then + -- Disable this test if Derived_Type completes an incomplete + -- type because in such case more primitives can be added + -- later to the list of primitives of Derived_Type by routine + -- Process_Incomplete_Dependents - Set_Is_Character_Type (Derived_Type, True); + return True; + end if; - if Nkind (Indic) /= N_Subtype_Indication then + E := Next_Entity (E); + end loop; - -- If no explicit constraint, the bounds are those - -- of the parent type. + List := Collect_Primitive_Operations (Derived_Type); + Elmt := First_Elmt (List); - Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); - Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); - Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); - end if; + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Subp := Node (Op_Elmt); + New_Subp := Node (Elmt); - Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. - -- Because the implicit base is used in the conversion of the bounds, we - -- have to freeze it now. This is similar to what is done for numeric - -- types, and it equally suspicious, but otherwise a non-static bound - -- will have a reference to an unfrozen type, which is rejected by Gigi - -- (???). This requires specific care for definition of stream - -- attributes. For details, see comments at the end of - -- Build_Derived_Numeric_Type. + exit when Present (Interface_Alias (Subp)); - Freeze_Before (N, Implicit_Base); - end Derived_Standard_Character; + -- Handle hidden entities - ------------------------------ - -- Derived_Type_Declaration -- - ------------------------------ + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Hidden (Subp) + then + if Present (New_Subp) + and then Primitive_Names_Match (Subp, New_Subp) + then + Next_Elmt (Elmt); + end if; - procedure Derived_Type_Declaration - (T : Entity_Id; - N : Node_Id; - Is_Completion : Boolean) - is - Parent_Type : Entity_Id; + else + if not Present (New_Subp) + or else Ekind (Subp) /= Ekind (New_Subp) + or else not Primitive_Names_Match (Subp, New_Subp) + then + return False; + end if; + + Next_Elmt (Elmt); + end if; - function Comes_From_Generic (Typ : Entity_Id) return Boolean; - -- Check whether the parent type is a generic formal, or derives - -- directly or indirectly from one. + Next_Elmt (Op_Elmt); + end loop; - ------------------------ - -- Comes_From_Generic -- - ------------------------ + return True; + end Check_Derived_Type; + + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- + + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id) + is + Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); + Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); - function Comes_From_Generic (Typ : Entity_Id) return Boolean is begin - if Is_Generic_Type (Typ) then - return True; + pragma Assert (Is_Interface (Iface_Type)); - elsif Is_Generic_Type (Root_Type (Parent_Type)) then - return True; + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Subp, + Derived_Type => Derived_Type, + Parent_Type => Iface_Type, + Actual_Subp => Actual_Subp); - elsif Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - and then Is_Generic_Type (Root_Type (Full_View (Typ))) - then - return True; + -- Given that this new interface entity corresponds with a primitive + -- of the parent that was not overridden we must leave it associated + -- with its parent primitive to ensure that it will share the same + -- dispatch table slot when overridden. - elsif Is_Generic_Actual_Type (Typ) then - return True; + if No (Actual_Subp) then + Set_Alias (New_Subp, Subp); + + -- For instantiations this is not needed since the previous call to + -- Derive_Subprogram leaves the entity well decorated. else - return False; + pragma Assert (Alias (New_Subp) = Actual_Subp); + null; end if; - end Comes_From_Generic; + end Derive_Interface_Subprogram; -- Local variables - Def : constant Node_Id := Type_Definition (N); - Iface_Def : Node_Id; - Indic : constant Node_Id := Subtype_Indication (Def); - Extension : constant Node_Id := Record_Extension_Part (Def); - Parent_Node : Node_Id; - Taggd : Boolean; + Alias_Subp : Entity_Id; + Act_List : Elist_Id; + Act_Elmt : Elmt_Id; + Act_Subp : Entity_Id := Empty; + Elmt : Elmt_Id; + Need_Search : Boolean := False; + New_Subp : Entity_Id := Empty; + Parent_Base : Entity_Id; + Subp : Entity_Id; - -- Start of processing for Derived_Type_Declaration + -- Start of processing for Derive_Subprograms begin - Parent_Type := Find_Type_Of_Subtype_Indic (Indic); - - -- Ada 2005 (AI-251): In case of interface derivation check that the - -- parent is also an interface. - - if Interface_Present (Def) then - Check_SPARK_05_Restriction ("interface is not allowed", Def); - - if not Is_Interface (Parent_Type) then - Diagnose_Interface (Indic, Parent_Type); - - else - Parent_Node := Parent (Base_Type (Parent_Type)); - Iface_Def := Type_Definition (Parent_Node); + if Ekind (Parent_Type) = E_Record_Type_With_Private + and then Has_Discriminants (Parent_Type) + and then Present (Full_View (Parent_Type)) + then + Parent_Base := Full_View (Parent_Type); + else + Parent_Base := Parent_Type; + end if; - -- Ada 2005 (AI-251): Limited interfaces can only inherit from - -- other limited interfaces. + if Present (Generic_Actual) then + Act_List := Collect_Primitive_Operations (Generic_Actual); + Act_Elmt := First_Elmt (Act_List); + else + Act_List := No_Elist; + Act_Elmt := No_Elmt; + end if; - if Limited_Present (Def) then - if Limited_Present (Iface_Def) then - null; + -- Derive primitives inherited from the parent. Note that if the generic + -- actual is present, this is not really a type derivation, it is a + -- completion within an instance. - elsif Protected_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + -- Case 1: Derived_Type does not implement interfaces - elsif Synchronized_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + if not Is_Tagged_Type (Derived_Type) + or else (not Has_Interfaces (Derived_Type) + and then not (Present (Generic_Actual) + and then Has_Interfaces (Generic_Actual))) + then + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - elsif Task_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared as a task interface", - N, Parent_Type); + -- Literals are derived earlier in the process of building the + -- derived type, and are skipped here. - else - Error_Msg_N - ("(Ada 2005) limited interface cannot " - & "inherit from non-limited interface", Indic); - end if; + if Ekind (Subp) = E_Enumeration_Literal then + null; - -- Ada 2005 (AI-345): Non-limited interfaces can only inherit - -- from non-limited or limited interfaces. + -- The actual is a direct descendant and the common primitive + -- operations appear in the same order. - elsif not Protected_Present (Def) - and then not Synchronized_Present (Def) - and then not Task_Present (Def) - then - if Limited_Present (Iface_Def) then - null; + -- If the generic parent type is present, the derived type is an + -- instance of a formal derived type, and within the instance its + -- operations are those of the actual. We derive from the formal + -- type but make the inherited operations aliases of the + -- corresponding operations of the actual. - elsif Protected_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant + (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); - elsif Synchronized_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); - elsif Task_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared as a task interface", - N, Parent_Type); - else - null; + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); end if; end if; - end if; - end if; - if Is_Tagged_Type (Parent_Type) - and then Is_Concurrent_Type (Parent_Type) - and then not Is_Interface (Parent_Type) - then - Error_Msg_N - ("parent type of a record extension cannot be " - & "a synchronized tagged type (RM 3.9.1 (3/1))", N); - Set_Etype (T, Any_Type); - return; - end if; + Next_Elmt (Elmt); + end loop; - -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor - -- interfaces + -- Case 2: Derived_Type implements interfaces - if Is_Tagged_Type (Parent_Type) - and then Is_Non_Empty_List (Interface_List (Def)) - then - declare - Intf : Node_Id; - T : Entity_Id; + else + -- If the parent type has no predefined primitives we remove + -- predefined primitives from the list of primitives of generic + -- actual to simplify the complexity of this algorithm. - begin - Intf := First (Interface_List (Def)); - while Present (Intf) loop - T := Find_Type_Of_Subtype_Indic (Intf); + if Present (Generic_Actual) then + declare + Has_Predefined_Primitives : Boolean := False; - if not Is_Interface (T) then - Diagnose_Interface (Intf, T); + begin + -- Check if the parent type has predefined primitives - -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow - -- a limited type from having a nonlimited progenitor. + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - elsif (Limited_Present (Def) - or else (not Is_Interface (Parent_Type) - and then Is_Limited_Type (Parent_Type))) - and then not Is_Limited_Interface (T) - then - Error_Msg_NE - ("progenitor interface& of limited type must be limited", - N, T); - end if; + if Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + Has_Predefined_Primitives := True; + exit; + end if; - Next (Intf); - end loop; - end; - end if; + Next_Elmt (Elmt); + end loop; - if Parent_Type = Any_Type - or else Etype (Parent_Type) = Any_Type - or else (Is_Class_Wide_Type (Parent_Type) - and then Etype (Parent_Type) = T) - then - -- If Parent_Type is undefined or illegal, make new type into a - -- subtype of Any_Type, and set a few attributes to prevent cascaded - -- errors. If this is a self-definition, emit error now. + -- Remove predefined primitives of Generic_Actual. We must use + -- an auxiliary list because in case of tagged types the value + -- returned by Collect_Primitive_Operations is the value stored + -- in its Primitive_Operations attribute (and we don't want to + -- modify its current contents). - if T = Parent_Type - or else T = Etype (Parent_Type) - then - Error_Msg_N ("type cannot be used in its own definition", Indic); - end if; + if not Has_Predefined_Primitives then + declare + Aux_List : constant Elist_Id := New_Elmt_List; - Set_Ekind (T, Ekind (Parent_Type)); - Set_Etype (T, Any_Type); - Set_Scalar_Range (T, Scalar_Range (Any_Type)); + begin + Elmt := First_Elmt (Act_List); + while Present (Elmt) loop + Subp := Node (Elmt); - if Is_Tagged_Type (T) - and then Is_Record_Type (T) - then - Set_Direct_Primitive_Operations (T, New_Elmt_List); - end if; + if not Is_Predefined_Dispatching_Operation (Subp) + or else Comes_From_Source (Subp) + then + Append_Elmt (Subp, Aux_List); + end if; - return; - end if; + Next_Elmt (Elmt); + end loop; - -- Ada 2005 (AI-251): The case in which the parent of the full-view is - -- an interface is special because the list of interfaces in the full - -- view can be given in any order. For example: + Act_List := Aux_List; + end; + end if; - -- type A is interface; - -- type B is interface and A; - -- type D is new B with private; - -- private - -- type D is new A and B with null record; -- 1 -- + Act_Elmt := First_Elmt (Act_List); + Act_Subp := Node (Act_Elmt); + end; + end if; - -- In this case we perform the following transformation of -1-: + -- Stage 1: If the generic actual is not present we derive the + -- primitives inherited from the parent type. If the generic parent + -- type is present, the derived type is an instance of a formal + -- derived type, and within the instance its operations are those of + -- the actual. We derive from the formal type but make the inherited + -- operations aliases of the corresponding operations of the actual. - -- type D is new B and A with null record; + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Ultimate_Alias (Subp); - -- If the parent of the full-view covers the parent of the partial-view - -- we have two possible cases: + -- Do not derive internal entities of the parent that link + -- interface primitives with their covering primitive. These + -- entities will be added to this type when frozen. - -- 1) They have the same parent - -- 2) The parent of the full-view implements some further interfaces + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; - -- In both cases we do not need to perform the transformation. In the - -- first case the source program is correct and the transformation is - -- not needed; in the second case the source program does not fulfill - -- the no-hidden interfaces rule (AI-396) and the error will be reported - -- later. + -- If the generic actual is present find the corresponding + -- operation in the generic actual. If the parent type is a + -- direct ancestor of the derived type then, even if it is an + -- interface, the operations are inherited from the primary + -- dispatch table and are in the proper order. If we detect here + -- that primitives are not in the same order we traverse the list + -- of primitive operations of the actual to find the one that + -- implements the interface primitive. - -- This transformation not only simplifies the rest of the analysis of - -- this type declaration but also simplifies the correct generation of - -- the object layout to the expander. + if Need_Search + or else + (Present (Generic_Actual) + and then Present (Act_Subp) + and then not + (Primitive_Names_Match (Subp, Act_Subp) + and then + Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True))) + then + pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, + Use_Full_View => True)); - if In_Private_Part (Current_Scope) - and then Is_Interface (Parent_Type) - then - declare - Iface : Node_Id; - Partial_View : Entity_Id; - Partial_View_Parent : Entity_Id; - New_Iface : Node_Id; + -- Remember that we need searching for all pending primitives - begin - -- Look for the associated private type declaration + Need_Search := True; - Partial_View := First_Entity (Current_Scope); - loop - exit when No (Partial_View) - or else (Has_Private_Declaration (Partial_View) - and then Full_View (Partial_View) = T); + -- Handle entities associated with interface primitives - Next_Entity (Partial_View); - end loop; + if Present (Alias_Subp) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + -- Search for the primitive in the homonym chain - -- If the partial view was not found then the source code has - -- errors and the transformation is not needed. + Act_Subp := + Find_Primitive_Covering_Interface + (Tagged_Type => Generic_Actual, + Iface_Prim => Alias_Subp); - if Present (Partial_View) then - Partial_View_Parent := Etype (Partial_View); + -- Previous search may not locate primitives covering + -- interfaces defined in generics units or instantiations. + -- (it fails if the covering primitive has formals whose + -- type is also defined in generics or instantiations). + -- In such case we search in the list of primitives of the + -- generic actual for the internal entity that links the + -- interface primitive and the covering primitive. - -- If the parent of the full-view covers the parent of the - -- partial-view we have nothing else to do. + if No (Act_Subp) + and then Is_Generic_Type (Parent_Type) + then + -- This code has been designed to handle only generic + -- formals that implement interfaces that are defined + -- in a generic unit or instantiation. If this code is + -- needed for other cases we must review it because + -- (given that it relies on Original_Location to locate + -- the primitive of Generic_Actual that covers the + -- interface) it could leave linked through attribute + -- Alias entities of unrelated instantiations). - if Interface_Present_In_Ancestor - (Parent_Type, Partial_View_Parent) - then - null; + pragma Assert + (Is_Generic_Unit + (Scope (Find_Dispatching_Type (Alias_Subp))) + or else + Instantiation_Depth + (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); - -- Traverse the list of interfaces of the full-view to look - -- for the parent of the partial-view and perform the tree - -- transformation. + declare + Iface_Prim_Loc : constant Source_Ptr := + Original_Location (Sloc (Alias_Subp)); - else - Iface := First (Interface_List (Def)); - while Present (Iface) loop - if Etype (Iface) = Etype (Partial_View) then - Rewrite (Subtype_Indication (Def), - New_Copy (Subtype_Indication - (Parent (Partial_View)))); + Elmt : Elmt_Id; + Prim : Entity_Id; - New_Iface := - Make_Identifier (Sloc (N), Chars (Parent_Type)); - Append (New_Iface, Interface_List (Def)); + begin + Elmt := + First_Elmt (Primitive_Operations (Generic_Actual)); - -- Analyze the transformed code + Search : while Present (Elmt) loop + Prim := Node (Elmt); - Derived_Type_Declaration (T, N, Is_Completion); - return; - end if; + if Present (Interface_Alias (Prim)) + and then Original_Location + (Sloc (Interface_Alias (Prim))) = + Iface_Prim_Loc + then + Act_Subp := Alias (Prim); + exit Search; + end if; - Next (Iface); - end loop; - end if; - end if; - end; - end if; + Next_Elmt (Elmt); + end loop Search; + end; + end if; - -- Only composite types other than array types are allowed to have - -- discriminants. + pragma Assert (Present (Act_Subp) + or else Is_Abstract_Type (Generic_Actual) + or else Serious_Errors_Detected > 0); - if Present (Discriminant_Specifications (N)) then - if (Is_Elementary_Type (Parent_Type) - or else Is_Array_Type (Parent_Type)) - and then not Error_Posted (N) - then - Error_Msg_N - ("elementary or array type cannot have discriminants", - Defining_Identifier (First (Discriminant_Specifications (N)))); - Set_Has_Discriminants (T, False); + -- Handle predefined primitives plus the rest of user-defined + -- primitives - -- The type is allowed to have discriminants + else + Act_Elmt := First_Elmt (Act_List); + while Present (Act_Elmt) loop + Act_Subp := Node (Act_Elmt); - else - Check_SPARK_05_Restriction ("discriminant type is not allowed", N); - end if; - end if; + exit when Primitive_Names_Match (Subp, Act_Subp) + and then Type_Conformant + (Subp, Act_Subp, + Skip_Controlling_Formals => True) + and then No (Interface_Alias (Act_Subp)); - -- In Ada 83, a derived type defined in a package specification cannot - -- be used for further derivation until the end of its visible part. - -- Note that derivation in the private part of the package is allowed. + Next_Elmt (Act_Elmt); + end loop; - if Ada_Version = Ada_83 - and then Is_Derived_Type (Parent_Type) - and then In_Visible_Part (Scope (Parent_Type)) - then - if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then - Error_Msg_N - ("(Ada 83): premature use of type for derivation", Indic); - end if; - end if; + if No (Act_Elmt) then + Act_Subp := Empty; + end if; + end if; + end if; - -- Check for early use of incomplete or private type + -- Case 1: If the parent is a limited interface then it has the + -- predefined primitives of synchronized interfaces. However, the + -- actual type may be a non-limited type and hence it does not + -- have such primitives. - if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then - Error_Msg_N ("premature derivation of incomplete type", Indic); - return; + if Present (Generic_Actual) + and then not Present (Act_Subp) + and then Is_Limited_Interface (Parent_Base) + and then Is_Predefined_Interface_Primitive (Subp) + then + null; - elsif (Is_Incomplete_Or_Private_Type (Parent_Type) - and then not Comes_From_Generic (Parent_Type)) - or else Has_Private_Component (Parent_Type) - then - -- The ancestor type of a formal type can be incomplete, in which - -- case only the operations of the partial view are available in the - -- generic. Subsequent checks may be required when the full view is - -- analyzed to verify that a derivation from a tagged type has an - -- extension. + -- Case 2: Inherit entities associated with interfaces that were + -- not covered by the parent type. We exclude here null interface + -- primitives because they do not need special management. - if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then - null; + -- We also exclude interface operations that are renamings. If the + -- subprogram is an explicit renaming of an interface primitive, + -- it is a regular primitive operation, and the presence of its + -- alias is not relevant: it has to be derived like any other + -- primitive. - elsif No (Underlying_Type (Parent_Type)) - or else Has_Private_Component (Parent_Type) - then - Error_Msg_N - ("premature derivation of derived or private type", Indic); + elsif Present (Alias (Subp)) + and then Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Renaming_Declaration + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not + (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Subp))) + then + -- If this is an abstract private type then we transfer the + -- derivation of the interface primitive from the partial view + -- to the full view. This is safe because all the interfaces + -- must be visible in the partial view. Done to avoid adding + -- a new interface derivation to the private part of the + -- enclosing package; otherwise this new derivation would be + -- decorated as hidden when the analysis of the enclosing + -- package completes. - -- Flag the type itself as being in error, this prevents some - -- nasty problems with subsequent uses of the malformed type. + if Is_Abstract_Type (Derived_Type) + and then In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Derived_Type) + then + declare + Partial_View : Entity_Id; + Elmt : Elmt_Id; + Ent : Entity_Id; - Set_Error_Posted (T); + begin + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then + Full_View (Partial_View) = Derived_Type); - -- Check that within the immediate scope of an untagged partial - -- view it's illegal to derive from the partial view if the - -- full view is tagged. (7.3(7)) + Next_Entity (Partial_View); + end loop; - -- We verify that the Parent_Type is a partial view by checking - -- that it is not a Full_Type_Declaration (i.e. a private type or - -- private extension declaration), to distinguish a partial view - -- from a derivation from a private type which also appears as - -- E_Private_Type. If the parent base type is not declared in an - -- enclosing scope there is no need to check. + -- If the partial view was not found then the source code + -- has errors and the derivation is not needed. - elsif Present (Full_View (Parent_Type)) - and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration - and then not Is_Tagged_Type (Parent_Type) - and then Is_Tagged_Type (Full_View (Parent_Type)) - and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) - then - Error_Msg_N - ("premature derivation from type with tagged full view", - Indic); - end if; - end if; + if Present (Partial_View) then + Elmt := + First_Elmt (Primitive_Operations (Partial_View)); + while Present (Elmt) loop + Ent := Node (Elmt); - -- Check that form of derivation is appropriate + if Present (Alias (Ent)) + and then Ultimate_Alias (Ent) = Alias (Subp) + then + Append_Elmt + (Ent, Primitive_Operations (Derived_Type)); + exit; + end if; - Taggd := Is_Tagged_Type (Parent_Type); + Next_Elmt (Elmt); + end loop; - -- Perhaps the parent type should be changed to the class-wide type's - -- specific type in this case to prevent cascading errors ??? + -- If the interface primitive was not found in the + -- partial view then this interface primitive was + -- overridden. We add a derivation to activate in + -- Derive_Progenitor_Subprograms the machinery to + -- search for it. - if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then - Error_Msg_N ("parent type must not be a class-wide type", Indic); - return; - end if; + if No (Elmt) then + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; + end if; + end; + else + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; - if Present (Extension) and then not Taggd then - Error_Msg_N - ("type derived from untagged type cannot have extension", Indic); + -- Case 3: Common derivation - elsif No (Extension) and then Taggd then + else + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Subp, + Derived_Type => Derived_Type, + Parent_Type => Parent_Base, + Actual_Subp => Act_Subp); + end if; - -- If this declaration is within a private part (or body) of a - -- generic instantiation then the derivation is allowed (the parent - -- type can only appear tagged in this case if it's a generic actual - -- type, since it would otherwise have been rejected in the analysis - -- of the generic template). + -- No need to update Act_Elm if we must search for the + -- corresponding operation in the generic actual - if not Is_Generic_Actual_Type (Parent_Type) - or else In_Visible_Part (Scope (Parent_Type)) - then - if Is_Class_Wide_Type (Parent_Type) then - Error_Msg_N - ("parent type must not be a class-wide type", Indic); + if not Need_Search + and then Present (Act_Elmt) + then + Next_Elmt (Act_Elmt); + Act_Subp := Node (Act_Elmt); + end if; - -- Use specific type to prevent cascaded errors. + <> + Next_Elmt (Elmt); + end loop; - Parent_Type := Etype (Parent_Type); + -- Inherit additional operations from progenitors. If the derived + -- type is a generic actual, there are not new primitive operations + -- for the type because it has those of the actual, and therefore + -- nothing needs to be done. The renamings generated above are not + -- primitive operations, and their purpose is simply to make the + -- proper operations visible within an instantiation. - else - Error_Msg_N - ("type derived from tagged type must have extension", Indic); - end if; + if No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); end if; end if; - -- AI-443: Synchronized formal derived types require a private - -- extension. There is no point in checking the ancestor type or - -- the progenitors since the construct is wrong to begin with. + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test untagged types and instances + -- of formal derived types. We skip this test if we have already + -- reported serious errors in the sources. - if Ada_Version >= Ada_2005 - and then Is_Generic_Type (T) - and then Present (Original_Node (N)) - then - declare - Decl : constant Node_Id := Original_Node (N); + pragma Assert (not Is_Tagged_Type (Derived_Type) + or else Present (Generic_Actual) + or else Serious_Errors_Detected > 0 + or else Check_Derived_Type); + end Derive_Subprograms; - begin - if Nkind (Decl) = N_Formal_Type_Declaration - and then Nkind (Formal_Type_Definition (Decl)) = - N_Formal_Derived_Type_Definition - and then Synchronized_Present (Formal_Type_Definition (Decl)) - and then No (Extension) + -------------------------------- + -- Derived_Standard_Character -- + -------------------------------- - -- Avoid emitting a duplicate error message + procedure Derived_Standard_Character + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + Implicit_Base : constant Entity_Id := + Create_Itype + (E_Enumeration_Type, N, Derived_Type, 'B'); - and then not Error_Posted (Indic) - then - Error_Msg_N - ("synchronized derived type must have extension", N); - end if; - end; - end if; + Lo : Node_Id; + Hi : Node_Id; - if Null_Exclusion_Present (Def) - and then not Is_Access_Type (Parent_Type) - then - Error_Msg_N ("null exclusion can only apply to an access type", N); - end if; + begin + Discard_Node (Process_Subtype (Indic, N)); - -- Avoid deriving parent primitives of underlying record views + Set_Etype (Implicit_Base, Parent_Base); + Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); + Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); - Build_Derived_Type (N, Parent_Type, T, Is_Completion, - Derive_Subps => not Is_Underlying_Record_View (T)); + Set_Is_Character_Type (Implicit_Base, True); + Set_Has_Delayed_Freeze (Implicit_Base); - -- AI-419: The parent type of an explicitly limited derived type must - -- be a limited type or a limited interface. + -- The bounds of the implicit base are the bounds of the parent base. + -- Note that their type is the parent base. - if Limited_Present (Def) then - Set_Is_Limited_Record (T); + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); - if Is_Interface (T) then - Set_Is_Limited_Interface (T); - end if; + Set_Scalar_Range (Implicit_Base, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); - if not Is_Limited_Type (Parent_Type) - and then - (not Is_Interface (Parent_Type) - or else not Is_Limited_Interface (Parent_Type)) - then - -- AI05-0096: a derivation in the private part of an instance is - -- legal if the generic formal is untagged limited, and the actual - -- is non-limited. + Conditional_Delay (Derived_Type, Parent_Type); - if Is_Generic_Actual_Type (Parent_Type) - and then In_Private_Part (Current_Scope) - and then - not Is_Tagged_Type - (Generic_Parent_Type (Parent (Parent_Type))) - then - null; + Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + Set_Size_Info (Derived_Type, Parent_Type); - else - Error_Msg_NE - ("parent type& of limited type must be limited", - N, Parent_Type); - end if; - end if; + if Unknown_RM_Size (Derived_Type) then + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); end if; - -- In SPARK, there are no derived type definitions other than type - -- extensions of tagged record types. + Set_Is_Character_Type (Derived_Type, True); - if No (Extension) then - Check_SPARK_05_Restriction - ("derived type is not allowed", Original_Node (N)); - end if; - end Derived_Type_Declaration; + if Nkind (Indic) /= N_Subtype_Indication then - ------------------------ - -- Diagnose_Interface -- - ------------------------ + -- If no explicit constraint, the bounds are those + -- of the parent type. - procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is - begin - if not Is_Interface (E) - and then E /= Any_Type - then - Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); + Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); end if; - end Diagnose_Interface; - - ---------------------------------- - -- Enumeration_Type_Declaration -- - ---------------------------------- - procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Ev : Uint; - L : Node_Id; - R_Node : Node_Id; - B_Node : Node_Id; + Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - begin - -- Create identifier node representing lower bound + -- Because the implicit base is used in the conversion of the bounds, we + -- have to freeze it now. This is similar to what is done for numeric + -- types, and it equally suspicious, but otherwise a non-static bound + -- will have a reference to an unfrozen type, which is rejected by Gigi + -- (???). This requires specific care for definition of stream + -- attributes. For details, see comments at the end of + -- Build_Derived_Numeric_Type. - B_Node := New_Node (N_Identifier, Sloc (Def)); - L := First (Literals (Def)); - Set_Chars (B_Node, Chars (L)); - Set_Entity (B_Node, L); - Set_Etype (B_Node, T); - Set_Is_Static_Expression (B_Node, True); + Freeze_Before (N, Implicit_Base); + end Derived_Standard_Character; - R_Node := New_Node (N_Range, Sloc (Def)); - Set_Low_Bound (R_Node, B_Node); + ------------------------------ + -- Derived_Type_Declaration -- + ------------------------------ - Set_Ekind (T, E_Enumeration_Type); - Set_First_Literal (T, L); - Set_Etype (T, T); - Set_Is_Constrained (T); + procedure Derived_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Is_Completion : Boolean) + is + Parent_Type : Entity_Id; - Ev := Uint_0; + function Comes_From_Generic (Typ : Entity_Id) return Boolean; + -- Check whether the parent type is a generic formal, or derives + -- directly or indirectly from one. - -- Loop through literals of enumeration type setting pos and rep values - -- except that if the Ekind is already set, then it means the literal - -- was already constructed (case of a derived type declaration and we - -- should not disturb the Pos and Rep values. + ------------------------ + -- Comes_From_Generic -- + ------------------------ - while Present (L) loop - if Ekind (L) /= E_Enumeration_Literal then - Set_Ekind (L, E_Enumeration_Literal); - Set_Enumeration_Pos (L, Ev); - Set_Enumeration_Rep (L, Ev); - Set_Is_Known_Valid (L, True); - end if; + function Comes_From_Generic (Typ : Entity_Id) return Boolean is + begin + if Is_Generic_Type (Typ) then + return True; - Set_Etype (L, T); - New_Overloaded_Entity (L); - Generate_Definition (L); - Set_Convention (L, Convention_Intrinsic); + elsif Is_Generic_Type (Root_Type (Parent_Type)) then + return True; - -- Case of character literal + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Generic_Type (Root_Type (Full_View (Typ))) + then + return True; - if Nkind (L) = N_Defining_Character_Literal then - Set_Is_Character_Type (T, True); + elsif Is_Generic_Actual_Type (Typ) then + return True; - -- Check violation of No_Wide_Characters + else + return False; + end if; + end Comes_From_Generic; - if Restriction_Check_Required (No_Wide_Characters) then - Get_Name_String (Chars (L)); + -- Local variables - if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then - Check_Restriction (No_Wide_Characters, L); - end if; - end if; - end if; + Def : constant Node_Id := Type_Definition (N); + Iface_Def : Node_Id; + Indic : constant Node_Id := Subtype_Indication (Def); + Extension : constant Node_Id := Record_Extension_Part (Def); + Parent_Node : Node_Id; + Taggd : Boolean; - Ev := Ev + 1; - Next (L); - end loop; + -- Start of processing for Derived_Type_Declaration - -- Now create a node representing upper bound + begin + Parent_Type := Find_Type_Of_Subtype_Indic (Indic); - B_Node := New_Node (N_Identifier, Sloc (Def)); - Set_Chars (B_Node, Chars (Last (Literals (Def)))); - Set_Entity (B_Node, Last (Literals (Def))); - Set_Etype (B_Node, T); - Set_Is_Static_Expression (B_Node, True); + -- Ada 2005 (AI-251): In case of interface derivation check that the + -- parent is also an interface. - Set_High_Bound (R_Node, B_Node); + if Interface_Present (Def) then + Check_SPARK_05_Restriction ("interface is not allowed", Def); - -- Initialize various fields of the type. Some of this information - -- may be overwritten later through rep.clauses. + if not Is_Interface (Parent_Type) then + Diagnose_Interface (Indic, Parent_Type); - Set_Scalar_Range (T, R_Node); - Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); - Set_Enum_Esize (T); - Set_Enum_Pos_To_Rep (T, Empty); + else + Parent_Node := Parent (Base_Type (Parent_Type)); + Iface_Def := Type_Definition (Parent_Node); - -- Set Discard_Names if configuration pragma set, or if there is - -- a parameterless pragma in the current declarative region + -- Ada 2005 (AI-251): Limited interfaces can only inherit from + -- other limited interfaces. - if Global_Discard_Names or else Discard_Names (Scope (T)) then - Set_Discard_Names (T); - end if; + if Limited_Present (Def) then + if Limited_Present (Iface_Def) then + null; - -- Process end label if there is one + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); - if Present (Def) then - Process_End_Label (Def, 'e', T); - end if; - end Enumeration_Type_Declaration; + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); - --------------------------------- - -- Expand_To_Stored_Constraint -- - --------------------------------- + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); - function Expand_To_Stored_Constraint - (Typ : Entity_Id; - Constraint : Elist_Id) return Elist_Id - is - Explicitly_Discriminated_Type : Entity_Id; - Expansion : Elist_Id; - Discriminant : Entity_Id; + else + Error_Msg_N + ("(Ada 2005) limited interface cannot " + & "inherit from non-limited interface", Indic); + end if; - function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; - -- Find the nearest type that actually specifies discriminants + -- Ada 2005 (AI-345): Non-limited interfaces can only inherit + -- from non-limited or limited interfaces. - --------------------------------- - -- Type_With_Explicit_Discrims -- - --------------------------------- + elsif not Protected_Present (Def) + and then not Synchronized_Present (Def) + and then not Task_Present (Def) + then + if Limited_Present (Iface_Def) then + null; - function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is - Typ : constant E := Base_Type (Id); + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); - begin - if Ekind (Typ) in Incomplete_Or_Private_Kind then - if Present (Full_View (Typ)) then - return Type_With_Explicit_Discrims (Full_View (Typ)); - end if; + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); - else - if Has_Discriminants (Typ) then - return Typ; + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); + else + null; + end if; end if; end if; + end if; - if Etype (Typ) = Typ then - return Empty; - elsif Has_Discriminants (Typ) then - return Typ; - else - return Type_With_Explicit_Discrims (Etype (Typ)); - end if; - - end Type_With_Explicit_Discrims; + if Is_Tagged_Type (Parent_Type) + and then Is_Concurrent_Type (Parent_Type) + and then not Is_Interface (Parent_Type) + then + Error_Msg_N + ("parent type of a record extension cannot be " + & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + Set_Etype (T, Any_Type); + return; + end if; - -- Start of processing for Expand_To_Stored_Constraint + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor + -- interfaces - begin - if No (Constraint) - or else Is_Empty_Elmt_List (Constraint) + if Is_Tagged_Type (Parent_Type) + and then Is_Non_Empty_List (Interface_List (Def)) then - return No_Elist; - end if; + declare + Intf : Node_Id; + T : Entity_Id; - Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); + begin + Intf := First (Interface_List (Def)); + while Present (Intf) loop + T := Find_Type_Of_Subtype_Indic (Intf); - if No (Explicitly_Discriminated_Type) then - return No_Elist; - end if; + if not Is_Interface (T) then + Diagnose_Interface (Intf, T); - Expansion := New_Elmt_List; + -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow + -- a limited type from having a nonlimited progenitor. - Discriminant := - First_Stored_Discriminant (Explicitly_Discriminated_Type); - while Present (Discriminant) loop - Append_Elmt - (Get_Discriminant_Value - (Discriminant, Explicitly_Discriminated_Type, Constraint), - To => Expansion); - Next_Stored_Discriminant (Discriminant); - end loop; + elsif (Limited_Present (Def) + or else (not Is_Interface (Parent_Type) + and then Is_Limited_Type (Parent_Type))) + and then not Is_Limited_Interface (T) + then + Error_Msg_NE + ("progenitor interface& of limited type must be limited", + N, T); + end if; - return Expansion; - end Expand_To_Stored_Constraint; + Next (Intf); + end loop; + end; + end if; - --------------------------- - -- Find_Hidden_Interface -- - --------------------------- + if Parent_Type = Any_Type + or else Etype (Parent_Type) = Any_Type + or else (Is_Class_Wide_Type (Parent_Type) + and then Etype (Parent_Type) = T) + then + -- If Parent_Type is undefined or illegal, make new type into a + -- subtype of Any_Type, and set a few attributes to prevent cascaded + -- errors. If this is a self-definition, emit error now. - function Find_Hidden_Interface - (Src : Elist_Id; - Dest : Elist_Id) return Entity_Id - is - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; + if T = Parent_Type + or else T = Etype (Parent_Type) + then + Error_Msg_N ("type cannot be used in its own definition", Indic); + end if; - begin - if Present (Src) and then Present (Dest) then - Iface_Elmt := First_Elmt (Src); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + Set_Ekind (T, Ekind (Parent_Type)); + Set_Etype (T, Any_Type); + Set_Scalar_Range (T, Scalar_Range (Any_Type)); - if Is_Interface (Iface) - and then not Contain_Interface (Iface, Dest) - then - return Iface; - end if; + if Is_Tagged_Type (T) + and then Is_Record_Type (T) + then + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; - Next_Elmt (Iface_Elmt); - end loop; + return; end if; - return Empty; - end Find_Hidden_Interface; + -- Ada 2005 (AI-251): The case in which the parent of the full-view is + -- an interface is special because the list of interfaces in the full + -- view can be given in any order. For example: - -------------------- - -- Find_Type_Name -- - -------------------- + -- type A is interface; + -- type B is interface and A; + -- type D is new B with private; + -- private + -- type D is new A and B with null record; -- 1 -- - function Find_Type_Name (N : Node_Id) return Entity_Id is - Id : constant Entity_Id := Defining_Identifier (N); - Prev : Entity_Id; - New_Id : Entity_Id; - Prev_Par : Node_Id; + -- In this case we perform the following transformation of -1-: - procedure Check_Duplicate_Aspects; - -- Check that aspects specified in a completion have not been specified - -- already in the partial view. Type_Invariant and others can be - -- specified on either view but never on both. + -- type D is new B and A with null record; - procedure Tag_Mismatch; - -- Diagnose a tagged partial view whose full view is untagged. - -- We post the message on the full view, with a reference to - -- the previous partial view. The partial view can be private - -- or incomplete, and these are handled in a different manner, - -- so we determine the position of the error message from the - -- respective slocs of both. + -- If the parent of the full-view covers the parent of the partial-view + -- we have two possible cases: - ----------------------------- - -- Check_Duplicate_Aspects -- - ----------------------------- - procedure Check_Duplicate_Aspects is - Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); - Full_Aspects : constant List_Id := Aspect_Specifications (N); - F_Spec, P_Spec : Node_Id; + -- 1) They have the same parent + -- 2) The parent of the full-view implements some further interfaces - begin - if Present (Prev_Aspects) and then Present (Full_Aspects) then - F_Spec := First (Full_Aspects); - while Present (F_Spec) loop - P_Spec := First (Prev_Aspects); - while Present (P_Spec) loop - if - Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) - then - Error_Msg_N - ("aspect already specified in private declaration", - F_Spec); - Remove (F_Spec); - return; - end if; + -- In both cases we do not need to perform the transformation. In the + -- first case the source program is correct and the transformation is + -- not needed; in the second case the source program does not fulfill + -- the no-hidden interfaces rule (AI-396) and the error will be reported + -- later. - Next (P_Spec); - end loop; + -- This transformation not only simplifies the rest of the analysis of + -- this type declaration but also simplifies the correct generation of + -- the object layout to the expander. - Next (F_Spec); - end loop; - end if; - end Check_Duplicate_Aspects; + if In_Private_Part (Current_Scope) + and then Is_Interface (Parent_Type) + then + declare + Iface : Node_Id; + Partial_View : Entity_Id; + Partial_View_Parent : Entity_Id; + New_Iface : Node_Id; - ------------------ - -- Tag_Mismatch -- - ------------------ + begin + -- Look for the associated private type declaration - procedure Tag_Mismatch is - begin - if Sloc (Prev) < Sloc (Id) then - if Ada_Version >= Ada_2012 - and then Nkind (N) = N_Private_Type_Declaration - then - Error_Msg_NE - ("declaration of private } must be a tagged type ", Id, Prev); - else - Error_Msg_NE - ("full declaration of } must be a tagged type ", Id, Prev); - end if; + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then Full_View (Partial_View) = T); - else - if Ada_Version >= Ada_2012 - and then Nkind (N) = N_Private_Type_Declaration - then - Error_Msg_NE - ("declaration of private } must be a tagged type ", Prev, Id); - else - Error_Msg_NE - ("full declaration of } must be a tagged type ", Prev, Id); - end if; - end if; - end Tag_Mismatch; + Next_Entity (Partial_View); + end loop; - -- Start of processing for Find_Type_Name + -- If the partial view was not found then the source code has + -- errors and the transformation is not needed. - begin - -- Find incomplete declaration, if one was given + if Present (Partial_View) then + Partial_View_Parent := Etype (Partial_View); - Prev := Current_Entity_In_Scope (Id); + -- If the parent of the full-view covers the parent of the + -- partial-view we have nothing else to do. + + if Interface_Present_In_Ancestor + (Parent_Type, Partial_View_Parent) + then + null; - -- New type declaration + -- Traverse the list of interfaces of the full-view to look + -- for the parent of the partial-view and perform the tree + -- transformation. - if No (Prev) then - Enter_Name (Id); - return Id; + else + Iface := First (Interface_List (Def)); + while Present (Iface) loop + if Etype (Iface) = Etype (Partial_View) then + Rewrite (Subtype_Indication (Def), + New_Copy (Subtype_Indication + (Parent (Partial_View)))); - -- Previous declaration exists + New_Iface := + Make_Identifier (Sloc (N), Chars (Parent_Type)); + Append (New_Iface, Interface_List (Def)); - else - Prev_Par := Parent (Prev); + -- Analyze the transformed code - -- Error if not incomplete/private case except if previous - -- declaration is implicit, etc. Enter_Name will emit error if - -- appropriate. + Derived_Type_Declaration (T, N, Is_Completion); + return; + end if; - if not Is_Incomplete_Or_Private_Type (Prev) then - Enter_Name (Id); - New_Id := Id; + Next (Iface); + end loop; + end if; + end if; + end; + end if; - -- Check invalid completion of private or incomplete type + -- Only composite types other than array types are allowed to have + -- discriminants. - elsif not Nkind_In (N, N_Full_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) - and then - (Ada_Version < Ada_2012 - or else not Is_Incomplete_Type (Prev) - or else not Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration)) + if Present (Discriminant_Specifications (N)) then + if (Is_Elementary_Type (Parent_Type) + or else Is_Array_Type (Parent_Type)) + and then not Error_Posted (N) then - -- Completion must be a full type declarations (RM 7.3(4)) + Error_Msg_N + ("elementary or array type cannot have discriminants", + Defining_Identifier (First (Discriminant_Specifications (N)))); + Set_Has_Discriminants (T, False); - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_NE ("invalid completion of }", Id, Prev); + -- The type is allowed to have discriminants - -- Set scope of Id to avoid cascaded errors. Entity is never - -- examined again, except when saving globals in generics. + else + Check_SPARK_05_Restriction ("discriminant type is not allowed", N); + end if; + end if; - Set_Scope (Id, Current_Scope); - New_Id := Id; + -- In Ada 83, a derived type defined in a package specification cannot + -- be used for further derivation until the end of its visible part. + -- Note that derivation in the private part of the package is allowed. - -- If this is a repeated incomplete declaration, no further - -- checks are possible. + if Ada_Version = Ada_83 + and then Is_Derived_Type (Parent_Type) + and then In_Visible_Part (Scope (Parent_Type)) + then + if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then + Error_Msg_N + ("(Ada 83): premature use of type for derivation", Indic); + end if; + end if; - if Nkind (N) = N_Incomplete_Type_Declaration then - return Prev; - end if; + -- Check for early use of incomplete or private type - -- Case of full declaration of incomplete type + if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + Error_Msg_N ("premature derivation of incomplete type", Indic); + return; - elsif Ekind (Prev) = E_Incomplete_Type - and then (Ada_Version < Ada_2012 - or else No (Full_View (Prev)) - or else not Is_Private_Type (Full_View (Prev))) + elsif (Is_Incomplete_Or_Private_Type (Parent_Type) + and then not Comes_From_Generic (Parent_Type)) + or else Has_Private_Component (Parent_Type) + then + -- The ancestor type of a formal type can be incomplete, in which + -- case only the operations of the partial view are available in the + -- generic. Subsequent checks may be required when the full view is + -- analyzed to verify that a derivation from a tagged type has an + -- extension. + + if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then + null; + + elsif No (Underlying_Type (Parent_Type)) + or else Has_Private_Component (Parent_Type) then - -- Indicate that the incomplete declaration has a matching full - -- declaration. The defining occurrence of the incomplete - -- declaration remains the visible one, and the procedure - -- Get_Full_View dereferences it whenever the type is used. + Error_Msg_N + ("premature derivation of derived or private type", Indic); - if Present (Full_View (Prev)) then - Error_Msg_NE ("invalid redeclaration of }", Id, Prev); - end if; + -- Flag the type itself as being in error, this prevents some + -- nasty problems with subsequent uses of the malformed type. - Set_Full_View (Prev, Id); - Append_Entity (Id, Current_Scope); - Set_Is_Public (Id, Is_Public (Prev)); - Set_Is_Internal (Id); - New_Id := Prev; + Set_Error_Posted (T); - -- If the incomplete view is tagged, a class_wide type has been - -- created already. Use it for the private type as well, in order - -- to prevent multiple incompatible class-wide types that may be - -- created for self-referential anonymous access components. + -- Check that within the immediate scope of an untagged partial + -- view it's illegal to derive from the partial view if the + -- full view is tagged. (7.3(7)) - if Is_Tagged_Type (Prev) - and then Present (Class_Wide_Type (Prev)) - then - Set_Ekind (Id, Ekind (Prev)); -- will be reset later - Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); + -- We verify that the Parent_Type is a partial view by checking + -- that it is not a Full_Type_Declaration (i.e. a private type or + -- private extension declaration), to distinguish a partial view + -- from a derivation from a private type which also appears as + -- E_Private_Type. If the parent base type is not declared in an + -- enclosing scope there is no need to check. - -- If the incomplete type is completed by a private declaration - -- the class-wide type remains associated with the incomplete - -- type, to prevent order-of-elaboration issues in gigi, else - -- we associate the class-wide type with the known full view. + elsif Present (Full_View (Parent_Type)) + and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration + and then not Is_Tagged_Type (Parent_Type) + and then Is_Tagged_Type (Full_View (Parent_Type)) + and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) + then + Error_Msg_N + ("premature derivation from type with tagged full view", + Indic); + end if; + end if; - if Nkind (N) /= N_Private_Type_Declaration then - Set_Etype (Class_Wide_Type (Id), Id); - end if; - end if; + -- Check that form of derivation is appropriate - -- Case of full declaration of private type + Taggd := Is_Tagged_Type (Parent_Type); - else - -- If the private type was a completion of an incomplete type then - -- update Prev to reference the private type + -- Perhaps the parent type should be changed to the class-wide type's + -- specific type in this case to prevent cascading errors ??? - if Ada_Version >= Ada_2012 - and then Ekind (Prev) = E_Incomplete_Type - and then Present (Full_View (Prev)) - and then Is_Private_Type (Full_View (Prev)) - then - Prev := Full_View (Prev); - Prev_Par := Parent (Prev); - end if; + if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N ("parent type must not be a class-wide type", Indic); + return; + end if; - if Nkind (N) = N_Full_Type_Declaration - and then Nkind_In - (Type_Definition (N), N_Record_Definition, - N_Derived_Type_Definition) - and then Interface_Present (Type_Definition (N)) - then - Error_Msg_N - ("completion of private type cannot be an interface", N); - end if; + if Present (Extension) and then not Taggd then + Error_Msg_N + ("type derived from untagged type cannot have extension", Indic); - if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then - if Etype (Prev) /= Prev then + elsif No (Extension) and then Taggd then - -- Prev is a private subtype or a derived type, and needs - -- no completion. + -- If this declaration is within a private part (or body) of a + -- generic instantiation then the derivation is allowed (the parent + -- type can only appear tagged in this case if it's a generic actual + -- type, since it would otherwise have been rejected in the analysis + -- of the generic template). - Error_Msg_NE ("invalid redeclaration of }", Id, Prev); - New_Id := Id; + if not Is_Generic_Actual_Type (Parent_Type) + or else In_Visible_Part (Scope (Parent_Type)) + then + if Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N + ("parent type must not be a class-wide type", Indic); - elsif Ekind (Prev) = E_Private_Type - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - Error_Msg_N - ("completion of nonlimited type cannot be limited", N); + -- Use specific type to prevent cascaded errors. - elsif Ekind (Prev) = E_Record_Type_With_Private - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - if not Is_Limited_Record (Prev) then - Error_Msg_N - ("completion of nonlimited type cannot be limited", N); + Parent_Type := Etype (Parent_Type); - elsif No (Interface_List (N)) then - Error_Msg_N - ("completion of tagged private type must be tagged", - N); - end if; - end if; + else + Error_Msg_N + ("type derived from tagged type must have extension", Indic); + end if; + end if; + end if; - -- Ada 2005 (AI-251): Private extension declaration of a task - -- type or a protected type. This case arises when covering - -- interface types. + -- AI-443: Synchronized formal derived types require a private + -- extension. There is no point in checking the ancestor type or + -- the progenitors since the construct is wrong to begin with. - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - null; + if Ada_Version >= Ada_2005 + and then Is_Generic_Type (T) + and then Present (Original_Node (N)) + then + declare + Decl : constant Node_Id := Original_Node (N); - elsif Nkind (N) /= N_Full_Type_Declaration - or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition - then - Error_Msg_N - ("full view of private extension must be an extension", N); + begin + if Nkind (Decl) = N_Formal_Type_Declaration + and then Nkind (Formal_Type_Definition (Decl)) = + N_Formal_Derived_Type_Definition + and then Synchronized_Present (Formal_Type_Definition (Decl)) + and then No (Extension) - elsif not (Abstract_Present (Parent (Prev))) - and then Abstract_Present (Type_Definition (N)) + -- Avoid emitting a duplicate error message + + and then not Error_Posted (Indic) then Error_Msg_N - ("full view of non-abstract extension cannot be abstract", N); + ("synchronized derived type must have extension", N); end if; + end; + end if; - if not In_Private_Part (Current_Scope) then - Error_Msg_N - ("declaration of full view must appear in private part", N); - end if; + if Null_Exclusion_Present (Def) + and then not Is_Access_Type (Parent_Type) + then + Error_Msg_N ("null exclusion can only apply to an access type", N); + end if; - if Ada_Version >= Ada_2012 then - Check_Duplicate_Aspects; - end if; + -- Avoid deriving parent primitives of underlying record views - Copy_And_Swap (Prev, Id); - Set_Has_Private_Declaration (Prev); - Set_Has_Private_Declaration (Id); + Build_Derived_Type (N, Parent_Type, T, Is_Completion, + Derive_Subps => not Is_Underlying_Record_View (T)); - -- Preserve aspect and iterator flags that may have been set on - -- the partial view. + -- AI-419: The parent type of an explicitly limited derived type must + -- be a limited type or a limited interface. - Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); - Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); + if Limited_Present (Def) then + Set_Is_Limited_Record (T); - -- If no error, propagate freeze_node from private to full view. - -- It may have been generated for an early operational item. + if Is_Interface (T) then + Set_Is_Limited_Interface (T); + end if; - if Present (Freeze_Node (Id)) - and then Serious_Errors_Detected = 0 - and then No (Full_View (Id)) + if not Is_Limited_Type (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) + then + -- AI05-0096: a derivation in the private part of an instance is + -- legal if the generic formal is untagged limited, and the actual + -- is non-limited. + + if Is_Generic_Actual_Type (Parent_Type) + and then In_Private_Part (Current_Scope) + and then + not Is_Tagged_Type + (Generic_Parent_Type (Parent (Parent_Type))) then - Set_Freeze_Node (Prev, Freeze_Node (Id)); - Set_Freeze_Node (Id, Empty); - Set_First_Rep_Item (Prev, First_Rep_Item (Id)); - end if; + null; - Set_Full_View (Id, Prev); - New_Id := Prev; + else + Error_Msg_NE + ("parent type& of limited type must be limited", + N, Parent_Type); + end if; end if; + end if; - -- Verify that full declaration conforms to partial one + -- In SPARK, there are no derived type definitions other than type + -- extensions of tagged record types. - if Is_Incomplete_Or_Private_Type (Prev) - and then Present (Discriminant_Specifications (Prev_Par)) - then - if Present (Discriminant_Specifications (N)) then - if Ekind (Prev) = E_Incomplete_Type then - Check_Discriminant_Conformance (N, Prev, Prev); - else - Check_Discriminant_Conformance (N, Prev, Id); - end if; + if No (Extension) then + Check_SPARK_05_Restriction + ("derived type is not allowed", Original_Node (N)); + end if; + end Derived_Type_Declaration; - else - Error_Msg_N - ("missing discriminants in full type declaration", N); + ------------------------ + -- Diagnose_Interface -- + ------------------------ - -- To avoid cascaded errors on subsequent use, share the - -- discriminants of the partial view. + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is + begin + if not Is_Interface (E) + and then E /= Any_Type + then + Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); + end if; + end Diagnose_Interface; - Set_Discriminant_Specifications (N, - Discriminant_Specifications (Prev_Par)); - end if; - end if; + ---------------------------------- + -- Enumeration_Type_Declaration -- + ---------------------------------- - -- A prior untagged partial view can have an associated class-wide - -- type due to use of the class attribute, and in this case the full - -- type must also be tagged. This Ada 95 usage is deprecated in favor - -- of incomplete tagged declarations, but we check for it. + procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Ev : Uint; + L : Node_Id; + R_Node : Node_Id; + B_Node : Node_Id; - if Is_Type (Prev) - and then (Is_Tagged_Type (Prev) - or else Present (Class_Wide_Type (Prev))) - then - -- Ada 2012 (AI05-0162): A private type may be the completion of - -- an incomplete type. + begin + -- Create identifier node representing lower bound - if Ada_Version >= Ada_2012 - and then Is_Incomplete_Type (Prev) - and then Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration) - then - -- No need to check private extensions since they are tagged + B_Node := New_Node (N_Identifier, Sloc (Def)); + L := First (Literals (Def)); + Set_Chars (B_Node, Chars (L)); + Set_Entity (B_Node, L); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); - if Nkind (N) = N_Private_Type_Declaration - and then not Tagged_Present (N) - then - Tag_Mismatch; - end if; + R_Node := New_Node (N_Range, Sloc (Def)); + Set_Low_Bound (R_Node, B_Node); - -- The full declaration is either a tagged type (including - -- a synchronized type that implements interfaces) or a - -- type extension, otherwise this is an error. + Set_Ekind (T, E_Enumeration_Type); + Set_First_Literal (T, L); + Set_Etype (T, T); + Set_Is_Constrained (T); - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - if No (Interface_List (N)) - and then not Error_Posted (N) - then - Tag_Mismatch; - end if; + Ev := Uint_0; - elsif Nkind (Type_Definition (N)) = N_Record_Definition then + -- Loop through literals of enumeration type setting pos and rep values + -- except that if the Ekind is already set, then it means the literal + -- was already constructed (case of a derived type declaration and we + -- should not disturb the Pos and Rep values. - -- Indicate that the previous declaration (tagged incomplete - -- or private declaration) requires the same on the full one. + while Present (L) loop + if Ekind (L) /= E_Enumeration_Literal then + Set_Ekind (L, E_Enumeration_Literal); + Set_Enumeration_Pos (L, Ev); + Set_Enumeration_Rep (L, Ev); + Set_Is_Known_Valid (L, True); + end if; - if not Tagged_Present (Type_Definition (N)) then - Tag_Mismatch; - Set_Is_Tagged_Type (Id); - end if; + Set_Etype (L, T); + New_Overloaded_Entity (L); + Generate_Definition (L); + Set_Convention (L, Convention_Intrinsic); - elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then - if No (Record_Extension_Part (Type_Definition (N))) then - Error_Msg_NE - ("full declaration of } must be a record extension", - Prev, Id); + -- Case of character literal - -- Set some attributes to produce a usable full view + if Nkind (L) = N_Defining_Character_Literal then + Set_Is_Character_Type (T, True); - Set_Is_Tagged_Type (Id); - end if; + -- Check violation of No_Wide_Characters - else - Tag_Mismatch; - end if; - end if; + if Restriction_Check_Required (No_Wide_Characters) then + Get_Name_String (Chars (L)); - if Present (Prev) - and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration - and then Present (Premature_Use (Parent (Prev))) - then - Error_Msg_Sloc := Sloc (N); - Error_Msg_N - ("\full declaration #", Premature_Use (Parent (Prev))); + if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then + Check_Restriction (No_Wide_Characters, L); + end if; + end if; end if; - return New_Id; - end if; - end Find_Type_Name; - - ------------------------- - -- Find_Type_Of_Object -- - ------------------------- + Ev := Ev + 1; + Next (L); + end loop; - function Find_Type_Of_Object - (Obj_Def : Node_Id; - Related_Nod : Node_Id) return Entity_Id - is - Def_Kind : constant Node_Kind := Nkind (Obj_Def); - P : Node_Id := Parent (Obj_Def); - T : Entity_Id; - Nam : Name_Id; + -- Now create a node representing upper bound - begin - -- If the parent is a component_definition node we climb to the - -- component_declaration node + B_Node := New_Node (N_Identifier, Sloc (Def)); + Set_Chars (B_Node, Chars (Last (Literals (Def)))); + Set_Entity (B_Node, Last (Literals (Def))); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); - if Nkind (P) = N_Component_Definition then - P := Parent (P); - end if; + Set_High_Bound (R_Node, B_Node); - -- Case of an anonymous array subtype + -- Initialize various fields of the type. Some of this information + -- may be overwritten later through rep.clauses. - if Nkind_In (Def_Kind, N_Constrained_Array_Definition, - N_Unconstrained_Array_Definition) - then - T := Empty; - Array_Type_Declaration (T, Obj_Def); + Set_Scalar_Range (T, R_Node); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Enum_Esize (T); + Set_Enum_Pos_To_Rep (T, Empty); - -- Create an explicit subtype whenever possible + -- Set Discard_Names if configuration pragma set, or if there is + -- a parameterless pragma in the current declarative region - elsif Nkind (P) /= N_Component_Declaration - and then Def_Kind = N_Subtype_Indication - then - -- Base name of subtype on object name, which will be unique in - -- the current scope. + if Global_Discard_Names or else Discard_Names (Scope (T)) then + Set_Discard_Names (T); + end if; - -- If this is a duplicate declaration, return base type, to avoid - -- generating duplicate anonymous types. + -- Process end label if there is one - if Error_Posted (P) then - Analyze (Subtype_Mark (Obj_Def)); - return Entity (Subtype_Mark (Obj_Def)); - end if; + if Present (Def) then + Process_End_Label (Def, 'e', T); + end if; + end Enumeration_Type_Declaration; - Nam := - New_External_Name - (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); + --------------------------------- + -- Expand_To_Stored_Constraint -- + --------------------------------- - T := Make_Defining_Identifier (Sloc (P), Nam); + function Expand_To_Stored_Constraint + (Typ : Entity_Id; + Constraint : Elist_Id) return Elist_Id + is + Explicitly_Discriminated_Type : Entity_Id; + Expansion : Elist_Id; + Discriminant : Entity_Id; - Insert_Action (Obj_Def, - Make_Subtype_Declaration (Sloc (P), - Defining_Identifier => T, - Subtype_Indication => Relocate_Node (Obj_Def))); + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; + -- Find the nearest type that actually specifies discriminants - -- This subtype may need freezing, and this will not be done - -- automatically if the object declaration is not in declarative - -- part. Since this is an object declaration, the type cannot always - -- be frozen here. Deferred constants do not freeze their type - -- (which often enough will be private). + --------------------------------- + -- Type_With_Explicit_Discrims -- + --------------------------------- - if Nkind (P) = N_Object_Declaration - and then Constant_Present (P) - and then No (Expression (P)) - then - null; + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is + Typ : constant E := Base_Type (Id); - -- Here we freeze the base type of object type to catch premature use - -- of discriminated private type without a full view. + begin + if Ekind (Typ) in Incomplete_Or_Private_Kind then + if Present (Full_View (Typ)) then + return Type_With_Explicit_Discrims (Full_View (Typ)); + end if; else - Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); + if Has_Discriminants (Typ) then + return Typ; + end if; end if; - -- Ada 2005 AI-406: the object definition in an object declaration - -- can be an access definition. - - elsif Def_Kind = N_Access_Definition then - T := Access_Definition (Related_Nod, Obj_Def); + if Etype (Typ) = Typ then + return Empty; + elsif Has_Discriminants (Typ) then + return Typ; + else + return Type_With_Explicit_Discrims (Etype (Typ)); + end if; - Set_Is_Local_Anonymous_Access - (T, - V => (Ada_Version < Ada_2012) - or else (Nkind (P) /= N_Object_Declaration) - or else Is_Library_Level_Entity (Defining_Identifier (P))); + end Type_With_Explicit_Discrims; - -- Otherwise, the object definition is just a subtype_mark + -- Start of processing for Expand_To_Stored_Constraint - else - T := Process_Subtype (Obj_Def, Related_Nod); + begin + if No (Constraint) + or else Is_Empty_Elmt_List (Constraint) + then + return No_Elist; + end if; - -- If expansion is disabled an object definition that is an aggregate - -- will not get expanded and may lead to scoping problems in the back - -- end, if the object is referenced in an inner scope. In that case - -- create an itype reference for the object definition now. This - -- may be redundant in some cases, but harmless. + Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); - if Is_Itype (T) - and then Nkind (Related_Nod) = N_Object_Declaration - and then ASIS_Mode - then - Build_Itype_Reference (T, Related_Nod); - end if; + if No (Explicitly_Discriminated_Type) then + return No_Elist; end if; - return T; - end Find_Type_Of_Object; - - -------------------------------- - -- Find_Type_Of_Subtype_Indic -- - -------------------------------- + Expansion := New_Elmt_List; - function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is - Typ : Entity_Id; + Discriminant := + First_Stored_Discriminant (Explicitly_Discriminated_Type); + while Present (Discriminant) loop + Append_Elmt + (Get_Discriminant_Value + (Discriminant, Explicitly_Discriminated_Type, Constraint), + To => Expansion); + Next_Stored_Discriminant (Discriminant); + end loop; - begin - -- Case of subtype mark with a constraint + return Expansion; + end Expand_To_Stored_Constraint; - if Nkind (S) = N_Subtype_Indication then - Find_Type (Subtype_Mark (S)); - Typ := Entity (Subtype_Mark (S)); + --------------------------- + -- Find_Hidden_Interface -- + --------------------------- - if not - Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) - then - Error_Msg_N - ("incorrect constraint for this kind of type", Constraint (S)); - Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); - end if; + function Find_Hidden_Interface + (Src : Elist_Id; + Dest : Elist_Id) return Entity_Id + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; - -- Otherwise we have a subtype mark without a constraint + begin + if Present (Src) and then Present (Dest) then + Iface_Elmt := First_Elmt (Src); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - elsif Error_Posted (S) then - Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); - return Any_Type; + if Is_Interface (Iface) + and then not Contain_Interface (Iface, Dest) + then + return Iface; + end if; - else - Find_Type (S); - Typ := Entity (S); + Next_Elmt (Iface_Elmt); + end loop; end if; - -- Check No_Wide_Characters restriction - - Check_Wide_Character_Restriction (Typ, S); - - return Typ; - end Find_Type_Of_Subtype_Indic; - - ------------------------------------- - -- Floating_Point_Type_Declaration -- - ------------------------------------- + return Empty; + end Find_Hidden_Interface; - procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Digs : constant Node_Id := Digits_Expression (Def); - Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); - Digs_Val : Uint; - Base_Typ : Entity_Id; - Implicit_Base : Entity_Id; - Bound : Node_Id; + -------------------- + -- Find_Type_Name -- + -------------------- - function Can_Derive_From (E : Entity_Id) return Boolean; - -- Find if given digits value, and possibly a specified range, allows - -- derivation from specified type + function Find_Type_Name (N : Node_Id) return Entity_Id is + Id : constant Entity_Id := Defining_Identifier (N); + Prev : Entity_Id; + New_Id : Entity_Id; + Prev_Par : Node_Id; - function Find_Base_Type return Entity_Id; - -- Find a predefined base type that Def can derive from, or generate - -- an error and substitute Long_Long_Float if none exists. + procedure Check_Duplicate_Aspects; + -- Check that aspects specified in a completion have not been specified + -- already in the partial view. Type_Invariant and others can be + -- specified on either view but never on both. - --------------------- - -- Can_Derive_From -- - --------------------- + procedure Tag_Mismatch; + -- Diagnose a tagged partial view whose full view is untagged. + -- We post the message on the full view, with a reference to + -- the previous partial view. The partial view can be private + -- or incomplete, and these are handled in a different manner, + -- so we determine the position of the error message from the + -- respective slocs of both. - function Can_Derive_From (E : Entity_Id) return Boolean is - Spec : constant Entity_Id := Real_Range_Specification (Def); + ----------------------------- + -- Check_Duplicate_Aspects -- + ----------------------------- + procedure Check_Duplicate_Aspects is + Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); + Full_Aspects : constant List_Id := Aspect_Specifications (N); + F_Spec, P_Spec : Node_Id; begin - -- Check specified "digits" constraint + if Present (Prev_Aspects) and then Present (Full_Aspects) then + F_Spec := First (Full_Aspects); + while Present (F_Spec) loop + P_Spec := First (Prev_Aspects); + while Present (P_Spec) loop + if + Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) + then + Error_Msg_N + ("aspect already specified in private declaration", + F_Spec); + Remove (F_Spec); + return; + end if; + + Next (P_Spec); + end loop; - if Digs_Val > Digits_Value (E) then - return False; + Next (F_Spec); + end loop; end if; + end Check_Duplicate_Aspects; - -- Check for matching range, if specified + ------------------ + -- Tag_Mismatch -- + ------------------ - if Present (Spec) then - if Expr_Value_R (Type_Low_Bound (E)) > - Expr_Value_R (Low_Bound (Spec)) + procedure Tag_Mismatch is + begin + if Sloc (Prev) < Sloc (Id) then + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration then - return False; + Error_Msg_NE + ("declaration of private } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); end if; - if Expr_Value_R (Type_High_Bound (E)) < - Expr_Value_R (High_Bound (Spec)) + else + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration then - return False; + Error_Msg_NE + ("declaration of private } must be a tagged type ", Prev, Id); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); end if; end if; + end Tag_Mismatch; - return True; - end Can_Derive_From; - - -------------------- - -- Find_Base_Type -- - -------------------- - - function Find_Base_Type return Entity_Id is - Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); - - begin - -- Iterate over the predefined types in order, returning the first - -- one that Def can derive from. - - while Present (Choice) loop - if Can_Derive_From (Node (Choice)) then - return Node (Choice); - end if; - - Next_Elmt (Choice); - end loop; + -- Start of processing for Find_Type_Name - -- If we can't derive from any existing type, use Long_Long_Float - -- and give appropriate message explaining the problem. + begin + -- Find incomplete declaration, if one was given - if Digs_Val > Max_Digs_Val then - -- It might be the case that there is a type with the requested - -- range, just not the combination of digits and range. + Prev := Current_Entity_In_Scope (Id); - Error_Msg_N - ("no predefined type has requested range and precision", - Real_Range_Specification (Def)); + -- New type declaration - else - Error_Msg_N - ("range too large for any predefined type", - Real_Range_Specification (Def)); - end if; + if No (Prev) then + Enter_Name (Id); + return Id; - return Standard_Long_Long_Float; - end Find_Base_Type; + -- Previous declaration exists - -- Start of processing for Floating_Point_Type_Declaration + else + Prev_Par := Parent (Prev); - begin - Check_Restriction (No_Floating_Point, Def); + -- Error if not incomplete/private case except if previous + -- declaration is implicit, etc. Enter_Name will emit error if + -- appropriate. - -- Create an implicit base type + if not Is_Incomplete_Or_Private_Type (Prev) then + Enter_Name (Id); + New_Id := Id; - Implicit_Base := - Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); + -- Check invalid completion of private or incomplete type - -- Analyze and verify digits value + elsif not Nkind_In (N, N_Full_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) + and then + (Ada_Version < Ada_2012 + or else not Is_Incomplete_Type (Prev) + or else not Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration)) + then + -- Completion must be a full type declarations (RM 7.3(4)) - Analyze_And_Resolve (Digs, Any_Integer); - Check_Digits_Expression (Digs); - Digs_Val := Expr_Value (Digs); + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_NE ("invalid completion of }", Id, Prev); - -- Process possible range spec and find correct type to derive from + -- Set scope of Id to avoid cascaded errors. Entity is never + -- examined again, except when saving globals in generics. - Process_Real_Range_Specification (Def); + Set_Scope (Id, Current_Scope); + New_Id := Id; - -- Check that requested number of digits is not too high. + -- If this is a repeated incomplete declaration, no further + -- checks are possible. - if Digs_Val > Max_Digs_Val then - -- The check for Max_Base_Digits may be somewhat expensive, as it - -- requires reading System, so only do it when necessary. + if Nkind (N) = N_Incomplete_Type_Declaration then + return Prev; + end if; - declare - Max_Base_Digits : constant Uint := - Expr_Value - (Expression - (Parent (RTE (RE_Max_Base_Digits)))); + -- Case of full declaration of incomplete type - begin - if Digs_Val > Max_Base_Digits then - Error_Msg_Uint_1 := Max_Base_Digits; - Error_Msg_N ("digits value out of range, maximum is ^", Digs); + elsif Ekind (Prev) = E_Incomplete_Type + and then (Ada_Version < Ada_2012 + or else No (Full_View (Prev)) + or else not Is_Private_Type (Full_View (Prev))) + then + -- Indicate that the incomplete declaration has a matching full + -- declaration. The defining occurrence of the incomplete + -- declaration remains the visible one, and the procedure + -- Get_Full_View dereferences it whenever the type is used. - elsif No (Real_Range_Specification (Def)) then - Error_Msg_Uint_1 := Max_Digs_Val; - Error_Msg_N ("types with more than ^ digits need range spec " - & "(RM 3.5.7(6))", Digs); + if Present (Full_View (Prev)) then + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); end if; - end; - end if; - - -- Find a suitable type to derive from or complain and use a substitute - Base_Typ := Find_Base_Type; + Set_Full_View (Prev, Id); + Append_Entity (Id, Current_Scope); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + New_Id := Prev; - -- If there are bounds given in the declaration use them as the bounds - -- of the type, otherwise use the bounds of the predefined base type - -- that was chosen based on the Digits value. + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the private type as well, in order + -- to prevent multiple incompatible class-wide types that may be + -- created for self-referential anonymous access components. - if Present (Real_Range_Specification (Def)) then - Set_Scalar_Range (T, Real_Range_Specification (Def)); - Set_Is_Constrained (T); + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); - -- The bounds of this range must be converted to machine numbers - -- in accordance with RM 4.9(38). + -- If the incomplete type is completed by a private declaration + -- the class-wide type remains associated with the incomplete + -- type, to prevent order-of-elaboration issues in gigi, else + -- we associate the class-wide type with the known full view. - Bound := Type_Low_Bound (T); + if Nkind (N) /= N_Private_Type_Declaration then + Set_Etype (Class_Wide_Type (Id), Id); + end if; + end if; - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); - end if; + -- Case of full declaration of private type - Bound := Type_High_Bound (T); + else + -- If the private type was a completion of an incomplete type then + -- update Prev to reference the private type - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); - end if; + if Ada_Version >= Ada_2012 + and then Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Is_Private_Type (Full_View (Prev)) + then + Prev := Full_View (Prev); + Prev_Par := Parent (Prev); + end if; - else - Set_Scalar_Range (T, Scalar_Range (Base_Typ)); - end if; + if Nkind (N) = N_Full_Type_Declaration + and then Nkind_In + (Type_Definition (N), N_Record_Definition, + N_Derived_Type_Definition) + and then Interface_Present (Type_Definition (N)) + then + Error_Msg_N + ("completion of private type cannot be an interface", N); + end if; - -- Complete definition of implicit base and declared first subtype + if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then + if Etype (Prev) /= Prev then - Set_Etype (Implicit_Base, Base_Typ); + -- Prev is a private subtype or a derived type, and needs + -- no completion. - Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - Set_Size_Info (Implicit_Base, (Base_Typ)); - Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); - Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); - Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); - Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + New_Id := Id; - Set_Ekind (T, E_Floating_Point_Subtype); - Set_Etype (T, Implicit_Base); + elsif Ekind (Prev) = E_Private_Type + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); - Set_Size_Info (T, (Implicit_Base)); - Set_RM_Size (T, RM_Size (Implicit_Base)); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); - end Floating_Point_Type_Declaration; + elsif Ekind (Prev) = E_Record_Type_With_Private + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if not Is_Limited_Record (Prev) then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); - ---------------------------- - -- Get_Discriminant_Value -- - ---------------------------- + elsif No (Interface_List (N)) then + Error_Msg_N + ("completion of tagged private type must be tagged", + N); + end if; + end if; - -- This is the situation: + -- Ada 2005 (AI-251): Private extension declaration of a task + -- type or a protected type. This case arises when covering + -- interface types. - -- There is a non-derived type + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + null; - -- type T0 (Dx, Dy, Dz...) + elsif Nkind (N) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition + then + Error_Msg_N + ("full view of private extension must be an extension", N); - -- There are zero or more levels of derivation, with each derivation - -- either purely inheriting the discriminants, or defining its own. + elsif not (Abstract_Present (Parent (Prev))) + and then Abstract_Present (Type_Definition (N)) + then + Error_Msg_N + ("full view of non-abstract extension cannot be abstract", N); + end if; - -- type Ti is new Ti-1 - -- or - -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) - -- or - -- subtype Ti is ... + if not In_Private_Part (Current_Scope) then + Error_Msg_N + ("declaration of full view must appear in private part", N); + end if; - -- The subtype issue is avoided by the use of Original_Record_Component, - -- and the fact that derived subtypes also derive the constraints. + if Ada_Version >= Ada_2012 then + Check_Duplicate_Aspects; + end if; - -- This chain leads back from + Copy_And_Swap (Prev, Id); + Set_Has_Private_Declaration (Prev); + Set_Has_Private_Declaration (Id); - -- Typ_For_Constraint + -- Preserve aspect and iterator flags that may have been set on + -- the partial view. - -- Typ_For_Constraint has discriminants, and the value for each - -- discriminant is given by its corresponding Elmt of Constraints. + Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); + Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); - -- Discriminant is some discriminant in this hierarchy + -- If no error, propagate freeze_node from private to full view. + -- It may have been generated for an early operational item. - -- We need to return its value + if Present (Freeze_Node (Id)) + and then Serious_Errors_Detected = 0 + and then No (Full_View (Id)) + then + Set_Freeze_Node (Prev, Freeze_Node (Id)); + Set_Freeze_Node (Id, Empty); + Set_First_Rep_Item (Prev, First_Rep_Item (Id)); + end if; - -- We do this by recursively searching each level, and looking for - -- Discriminant. Once we get to the bottom, we start backing up - -- returning the value for it which may in turn be a discriminant - -- further up, so on the backup we continue the substitution. + Set_Full_View (Id, Prev); + New_Id := Prev; + end if; - function Get_Discriminant_Value - (Discriminant : Entity_Id; - Typ_For_Constraint : Entity_Id; - Constraint : Elist_Id) return Node_Id - is - function Root_Corresponding_Discriminant - (Discr : Entity_Id) return Entity_Id; - -- Given a discriminant, traverse the chain of inherited discriminants - -- and return the topmost discriminant. + -- Verify that full declaration conforms to partial one - function Search_Derivation_Levels - (Ti : Entity_Id; - Discrim_Values : Elist_Id; - Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; - -- This is the routine that performs the recursive search of levels - -- as described above. + if Is_Incomplete_Or_Private_Type (Prev) + and then Present (Discriminant_Specifications (Prev_Par)) + then + if Present (Discriminant_Specifications (N)) then + if Ekind (Prev) = E_Incomplete_Type then + Check_Discriminant_Conformance (N, Prev, Prev); + else + Check_Discriminant_Conformance (N, Prev, Id); + end if; - ------------------------------------- - -- Root_Corresponding_Discriminant -- - ------------------------------------- + else + Error_Msg_N + ("missing discriminants in full type declaration", N); - function Root_Corresponding_Discriminant - (Discr : Entity_Id) return Entity_Id - is - D : Entity_Id; + -- To avoid cascaded errors on subsequent use, share the + -- discriminants of the partial view. - begin - D := Discr; - while Present (Corresponding_Discriminant (D)) loop - D := Corresponding_Discriminant (D); - end loop; + Set_Discriminant_Specifications (N, + Discriminant_Specifications (Prev_Par)); + end if; + end if; - return D; - end Root_Corresponding_Discriminant; + -- A prior untagged partial view can have an associated class-wide + -- type due to use of the class attribute, and in this case the full + -- type must also be tagged. This Ada 95 usage is deprecated in favor + -- of incomplete tagged declarations, but we check for it. - ------------------------------ - -- Search_Derivation_Levels -- - ------------------------------ + if Is_Type (Prev) + and then (Is_Tagged_Type (Prev) + or else Present (Class_Wide_Type (Prev))) + then + -- Ada 2012 (AI05-0162): A private type may be the completion of + -- an incomplete type. - function Search_Derivation_Levels - (Ti : Entity_Id; - Discrim_Values : Elist_Id; - Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id - is - Assoc : Elmt_Id; - Disc : Entity_Id; - Result : Node_Or_Entity_Id; - Result_Entity : Node_Id; + if Ada_Version >= Ada_2012 + and then Is_Incomplete_Type (Prev) + and then Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + then + -- No need to check private extensions since they are tagged - begin - -- If inappropriate type, return Error, this happens only in - -- cascaded error situations, and we want to avoid a blow up. + if Nkind (N) = N_Private_Type_Declaration + and then not Tagged_Present (N) + then + Tag_Mismatch; + end if; - if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then - return Error; - end if; + -- The full declaration is either a tagged type (including + -- a synchronized type that implements interfaces) or a + -- type extension, otherwise this is an error. - -- Look deeper if possible. Use Stored_Constraints only for - -- untagged types. For tagged types use the given constraint. - -- This asymmetry needs explanation??? + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if No (Interface_List (N)) + and then not Error_Posted (N) + then + Tag_Mismatch; + end if; - if not Stored_Discrim_Values - and then Present (Stored_Constraint (Ti)) - and then not Is_Tagged_Type (Ti) - then - Result := - Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); - else - declare - Td : constant Entity_Id := Etype (Ti); + elsif Nkind (Type_Definition (N)) = N_Record_Definition then - begin - if Td = Ti then - Result := Discriminant; + -- Indicate that the previous declaration (tagged incomplete + -- or private declaration) requires the same on the full one. - else - if Present (Stored_Constraint (Ti)) then - Result := - Search_Derivation_Levels - (Td, Stored_Constraint (Ti), True); - else - Result := - Search_Derivation_Levels - (Td, Discrim_Values, Stored_Discrim_Values); - end if; + if not Tagged_Present (Type_Definition (N)) then + Tag_Mismatch; + Set_Is_Tagged_Type (Id); end if; - end; - end if; - -- Extra underlying places to search, if not found above. For - -- concurrent types, the relevant discriminant appears in the - -- corresponding record. For a type derived from a private type - -- without discriminant, the full view inherits the discriminants - -- of the full view of the parent. + elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + if No (Record_Extension_Part (Type_Definition (N))) then + Error_Msg_NE + ("full declaration of } must be a record extension", + Prev, Id); - if Result = Discriminant then - if Is_Concurrent_Type (Ti) - and then Present (Corresponding_Record_Type (Ti)) - then - Result := - Search_Derivation_Levels ( - Corresponding_Record_Type (Ti), - Discrim_Values, - Stored_Discrim_Values); + -- Set some attributes to produce a usable full view - elsif Is_Private_Type (Ti) - and then not Has_Discriminants (Ti) - and then Present (Full_View (Ti)) - and then Etype (Full_View (Ti)) /= Ti - then - Result := - Search_Derivation_Levels ( - Full_View (Ti), - Discrim_Values, - Stored_Discrim_Values); + Set_Is_Tagged_Type (Id); + end if; + + else + Tag_Mismatch; end if; end if; - -- If Result is not a (reference to a) discriminant, return it, - -- otherwise set Result_Entity to the discriminant. - - if Nkind (Result) = N_Defining_Identifier then - pragma Assert (Result = Discriminant); - Result_Entity := Result; + if Present (Prev) + and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration + and then Present (Premature_Use (Parent (Prev))) + then + Error_Msg_Sloc := Sloc (N); + Error_Msg_N + ("\full declaration #", Premature_Use (Parent (Prev))); + end if; - else - if not Denotes_Discriminant (Result) then - return Result; - end if; + return New_Id; + end if; + end Find_Type_Name; - Result_Entity := Entity (Result); - end if; + ------------------------- + -- Find_Type_Of_Object -- + ------------------------- - -- See if this level of derivation actually has discriminants - -- because tagged derivations can add them, hence the lower - -- levels need not have any. + function Find_Type_Of_Object + (Obj_Def : Node_Id; + Related_Nod : Node_Id) return Entity_Id + is + Def_Kind : constant Node_Kind := Nkind (Obj_Def); + P : Node_Id := Parent (Obj_Def); + T : Entity_Id; + Nam : Name_Id; - if not Has_Discriminants (Ti) then - return Result; - end if; + begin + -- If the parent is a component_definition node we climb to the + -- component_declaration node - -- Scan Ti's discriminants for Result_Entity, - -- and return its corresponding value, if any. + if Nkind (P) = N_Component_Definition then + P := Parent (P); + end if; - Result_Entity := Original_Record_Component (Result_Entity); + -- Case of an anonymous array subtype - Assoc := First_Elmt (Discrim_Values); + if Nkind_In (Def_Kind, N_Constrained_Array_Definition, + N_Unconstrained_Array_Definition) + then + T := Empty; + Array_Type_Declaration (T, Obj_Def); - if Stored_Discrim_Values then - Disc := First_Stored_Discriminant (Ti); - else - Disc := First_Discriminant (Ti); - end if; + -- Create an explicit subtype whenever possible - while Present (Disc) loop - pragma Assert (Present (Assoc)); + elsif Nkind (P) /= N_Component_Declaration + and then Def_Kind = N_Subtype_Indication + then + -- Base name of subtype on object name, which will be unique in + -- the current scope. - if Original_Record_Component (Disc) = Result_Entity then - return Node (Assoc); - end if; + -- If this is a duplicate declaration, return base type, to avoid + -- generating duplicate anonymous types. - Next_Elmt (Assoc); + if Error_Posted (P) then + Analyze (Subtype_Mark (Obj_Def)); + return Entity (Subtype_Mark (Obj_Def)); + end if; - if Stored_Discrim_Values then - Next_Stored_Discriminant (Disc); - else - Next_Discriminant (Disc); - end if; - end loop; + Nam := + New_External_Name + (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); - -- Could not find it - -- - return Result; - end Search_Derivation_Levels; + T := Make_Defining_Identifier (Sloc (P), Nam); - -- Local Variables + Insert_Action (Obj_Def, + Make_Subtype_Declaration (Sloc (P), + Defining_Identifier => T, + Subtype_Indication => Relocate_Node (Obj_Def))); - Result : Node_Or_Entity_Id; + -- This subtype may need freezing, and this will not be done + -- automatically if the object declaration is not in declarative + -- part. Since this is an object declaration, the type cannot always + -- be frozen here. Deferred constants do not freeze their type + -- (which often enough will be private). - -- Start of processing for Get_Discriminant_Value + if Nkind (P) = N_Object_Declaration + and then Constant_Present (P) + and then No (Expression (P)) + then + null; - begin - -- ??? This routine is a gigantic mess and will be deleted. For the - -- time being just test for the trivial case before calling recurse. + -- Here we freeze the base type of object type to catch premature use + -- of discriminated private type without a full view. - if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then - declare - D : Entity_Id; - E : Elmt_Id; + else + Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); + end if; - begin - D := First_Discriminant (Typ_For_Constraint); - E := First_Elmt (Constraint); - while Present (D) loop - if Chars (D) = Chars (Discriminant) then - return Node (E); - end if; + -- Ada 2005 AI-406: the object definition in an object declaration + -- can be an access definition. - Next_Discriminant (D); - Next_Elmt (E); - end loop; - end; - end if; + elsif Def_Kind = N_Access_Definition then + T := Access_Definition (Related_Nod, Obj_Def); - Result := Search_Derivation_Levels - (Typ_For_Constraint, Constraint, False); + Set_Is_Local_Anonymous_Access + (T, + V => (Ada_Version < Ada_2012) + or else (Nkind (P) /= N_Object_Declaration) + or else Is_Library_Level_Entity (Defining_Identifier (P))); - -- ??? hack to disappear when this routine is gone + -- Otherwise, the object definition is just a subtype_mark - if Nkind (Result) = N_Defining_Identifier then - declare - D : Entity_Id; - E : Elmt_Id; + else + T := Process_Subtype (Obj_Def, Related_Nod); - begin - D := First_Discriminant (Typ_For_Constraint); - E := First_Elmt (Constraint); - while Present (D) loop - if Root_Corresponding_Discriminant (D) = Discriminant then - return Node (E); - end if; + -- If expansion is disabled an object definition that is an aggregate + -- will not get expanded and may lead to scoping problems in the back + -- end, if the object is referenced in an inner scope. In that case + -- create an itype reference for the object definition now. This + -- may be redundant in some cases, but harmless. - Next_Discriminant (D); - Next_Elmt (E); - end loop; - end; + if Is_Itype (T) + and then Nkind (Related_Nod) = N_Object_Declaration + and then ASIS_Mode + then + Build_Itype_Reference (T, Related_Nod); + end if; end if; - pragma Assert (Nkind (Result) /= N_Defining_Identifier); - return Result; - end Get_Discriminant_Value; + return T; + end Find_Type_Of_Object; - -------------------------- - -- Has_Range_Constraint -- - -------------------------- + -------------------------------- + -- Find_Type_Of_Subtype_Indic -- + -------------------------------- - function Has_Range_Constraint (N : Node_Id) return Boolean is - C : constant Node_Id := Constraint (N); + function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is + Typ : Entity_Id; begin - if Nkind (C) = N_Range_Constraint then - return True; + -- Case of subtype mark with a constraint - elsif Nkind (C) = N_Digits_Constraint then - return - Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) - or else - Present (Range_Constraint (C)); + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + Typ := Entity (Subtype_Mark (S)); - elsif Nkind (C) = N_Delta_Constraint then - return Present (Range_Constraint (C)); + if not + Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); + end if; + + -- Otherwise we have a subtype mark without a constraint + + elsif Error_Posted (S) then + Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); + return Any_Type; else - return False; + Find_Type (S); + Typ := Entity (S); end if; - end Has_Range_Constraint; - ------------------------ - -- Inherit_Components -- - ------------------------ + -- Check No_Wide_Characters restriction - function Inherit_Components - (N : Node_Id; - Parent_Base : Entity_Id; - Derived_Base : Entity_Id; - Is_Tagged : Boolean; - Inherit_Discr : Boolean; - Discs : Elist_Id) return Elist_Id - is - Assoc_List : constant Elist_Id := New_Elmt_List; + Check_Wide_Character_Restriction (Typ, S); - procedure Inherit_Component - (Old_C : Entity_Id; - Plain_Discrim : Boolean := False; - Stored_Discrim : Boolean := False); - -- Inherits component Old_C from Parent_Base to the Derived_Base. If - -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is - -- True, Old_C is a stored discriminant. If they are both false then - -- Old_C is a regular component. + return Typ; + end Find_Type_Of_Subtype_Indic; - ----------------------- - -- Inherit_Component -- - ----------------------- + ------------------------------------- + -- Floating_Point_Type_Declaration -- + ------------------------------------- - procedure Inherit_Component - (Old_C : Entity_Id; - Plain_Discrim : Boolean := False; - Stored_Discrim : Boolean := False) - is - procedure Set_Anonymous_Type (Id : Entity_Id); - -- Id denotes the entity of an access discriminant or anonymous - -- access component. Set the type of Id to either the same type of - -- Old_C or create a new one depending on whether the parent and - -- the child types are in the same scope. + procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Digs : constant Node_Id := Digits_Expression (Def); + Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); + Digs_Val : Uint; + Base_Typ : Entity_Id; + Implicit_Base : Entity_Id; + Bound : Node_Id; - ------------------------ - -- Set_Anonymous_Type -- - ------------------------ + function Can_Derive_From (E : Entity_Id) return Boolean; + -- Find if given digits value, and possibly a specified range, allows + -- derivation from specified type - procedure Set_Anonymous_Type (Id : Entity_Id) is - Old_Typ : constant Entity_Id := Etype (Old_C); + function Find_Base_Type return Entity_Id; + -- Find a predefined base type that Def can derive from, or generate + -- an error and substitute Long_Long_Float if none exists. - begin - if Scope (Parent_Base) = Scope (Derived_Base) then - Set_Etype (Id, Old_Typ); + --------------------- + -- Can_Derive_From -- + --------------------- - -- The parent and the derived type are in two different scopes. - -- Reuse the type of the original discriminant / component by - -- copying it in order to preserve all attributes. + function Can_Derive_From (E : Entity_Id) return Boolean is + Spec : constant Entity_Id := Real_Range_Specification (Def); - else - declare - Typ : constant Entity_Id := New_Copy (Old_Typ); + begin + -- Check specified "digits" constraint - begin - Set_Etype (Id, Typ); + if Digs_Val > Digits_Value (E) then + return False; + end if; - -- Since we do not generate component declarations for - -- inherited components, associate the itype with the - -- derived type. + -- Check for matching range, if specified - Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); - Set_Scope (Typ, Derived_Base); - end; + if Present (Spec) then + if Expr_Value_R (Type_Low_Bound (E)) > + Expr_Value_R (Low_Bound (Spec)) + then + return False; end if; - end Set_Anonymous_Type; - -- Local variables and constants + if Expr_Value_R (Type_High_Bound (E)) < + Expr_Value_R (High_Bound (Spec)) + then + return False; + end if; + end if; - New_C : constant Entity_Id := New_Copy (Old_C); + return True; + end Can_Derive_From; - Corr_Discrim : Entity_Id; - Discrim : Entity_Id; + -------------------- + -- Find_Base_Type -- + -------------------- - -- Start of processing for Inherit_Component + function Find_Base_Type return Entity_Id is + Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); begin - pragma Assert (not Is_Tagged or else not Stored_Discrim); - - Set_Parent (New_C, Parent (Old_C)); + -- Iterate over the predefined types in order, returning the first + -- one that Def can derive from. - -- Regular discriminants and components must be inserted in the scope - -- of the Derived_Base. Do it here. + while Present (Choice) loop + if Can_Derive_From (Node (Choice)) then + return Node (Choice); + end if; - if not Stored_Discrim then - Enter_Name (New_C); - end if; + Next_Elmt (Choice); + end loop; - -- For tagged types the Original_Record_Component must point to - -- whatever this field was pointing to in the parent type. This has - -- already been achieved by the call to New_Copy above. + -- If we can't derive from any existing type, use Long_Long_Float + -- and give appropriate message explaining the problem. - if not Is_Tagged then - Set_Original_Record_Component (New_C, New_C); - end if; + if Digs_Val > Max_Digs_Val then + -- It might be the case that there is a type with the requested + -- range, just not the combination of digits and range. - -- Set the proper type of an access discriminant + Error_Msg_N + ("no predefined type has requested range and precision", + Real_Range_Specification (Def)); - if Ekind (New_C) = E_Discriminant - and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type - then - Set_Anonymous_Type (New_C); + else + Error_Msg_N + ("range too large for any predefined type", + Real_Range_Specification (Def)); end if; - -- If we have inherited a component then see if its Etype contains - -- references to Parent_Base discriminants. In this case, replace - -- these references with the constraints given in Discs. We do not - -- do this for the partial view of private types because this is - -- not needed (only the components of the full view will be used - -- for code generation) and cause problem. We also avoid this - -- transformation in some error situations. + return Standard_Long_Long_Float; + end Find_Base_Type; - if Ekind (New_C) = E_Component then + -- Start of processing for Floating_Point_Type_Declaration - -- Set the proper type of an anonymous access component + begin + Check_Restriction (No_Floating_Point, Def); - if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then - Set_Anonymous_Type (New_C); + -- Create an implicit base type - elsif (Is_Private_Type (Derived_Base) - and then not Is_Generic_Type (Derived_Base)) - or else (Is_Empty_Elmt_List (Discs) - and then not Expander_Active) - then - Set_Etype (New_C, Etype (Old_C)); + Implicit_Base := + Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); - else - -- The current component introduces a circularity of the - -- following kind: + -- Analyze and verify digits value - -- limited with Pack_2; - -- package Pack_1 is - -- type T_1 is tagged record - -- Comp : access Pack_2.T_2; - -- ... - -- end record; - -- end Pack_1; + Analyze_And_Resolve (Digs, Any_Integer); + Check_Digits_Expression (Digs); + Digs_Val := Expr_Value (Digs); - -- with Pack_1; - -- package Pack_2 is - -- type T_2 is new Pack_1.T_1 with ...; - -- end Pack_2; + -- Process possible range spec and find correct type to derive from - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Derived_Base, N, Parent_Base, Discs)); - end if; - end if; + Process_Real_Range_Specification (Def); - -- In derived tagged types it is illegal to reference a non - -- discriminant component in the parent type. To catch this, mark - -- these components with an Ekind of E_Void. This will be reset in - -- Record_Type_Definition after processing the record extension of - -- the derived type. + -- Check that requested number of digits is not too high. - -- If the declaration is a private extension, there is no further - -- record extension to process, and the components retain their - -- current kind, because they are visible at this point. + if Digs_Val > Max_Digs_Val then + -- The check for Max_Base_Digits may be somewhat expensive, as it + -- requires reading System, so only do it when necessary. - if Is_Tagged and then Ekind (New_C) = E_Component - and then Nkind (N) /= N_Private_Extension_Declaration - then - Set_Ekind (New_C, E_Void); - end if; + declare + Max_Base_Digits : constant Uint := + Expr_Value + (Expression + (Parent (RTE (RE_Max_Base_Digits)))); - if Plain_Discrim then - Set_Corresponding_Discriminant (New_C, Old_C); - Build_Discriminal (New_C); + begin + if Digs_Val > Max_Base_Digits then + Error_Msg_Uint_1 := Max_Base_Digits; + Error_Msg_N ("digits value out of range, maximum is ^", Digs); - -- If we are explicitly inheriting a stored discriminant it will be - -- completely hidden. + elsif No (Real_Range_Specification (Def)) then + Error_Msg_Uint_1 := Max_Digs_Val; + Error_Msg_N ("types with more than ^ digits need range spec " + & "(RM 3.5.7(6))", Digs); + end if; + end; + end if; - elsif Stored_Discrim then - Set_Corresponding_Discriminant (New_C, Empty); - Set_Discriminal (New_C, Empty); - Set_Is_Completely_Hidden (New_C); + -- Find a suitable type to derive from or complain and use a substitute - -- Set the Original_Record_Component of each discriminant in the - -- derived base to point to the corresponding stored that we just - -- created. + Base_Typ := Find_Base_Type; - Discrim := First_Discriminant (Derived_Base); - while Present (Discrim) loop - Corr_Discrim := Corresponding_Discriminant (Discrim); + -- If there are bounds given in the declaration use them as the bounds + -- of the type, otherwise use the bounds of the predefined base type + -- that was chosen based on the Digits value. - -- Corr_Discrim could be missing in an error situation + if Present (Real_Range_Specification (Def)) then + Set_Scalar_Range (T, Real_Range_Specification (Def)); + Set_Is_Constrained (T); - if Present (Corr_Discrim) - and then Original_Record_Component (Corr_Discrim) = Old_C - then - Set_Original_Record_Component (Discrim, New_C); - end if; + -- The bounds of this range must be converted to machine numbers + -- in accordance with RM 4.9(38). - Next_Discriminant (Discrim); - end loop; + Bound := Type_Low_Bound (T); - Append_Entity (New_C, Derived_Base); + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); end if; - if not Is_Tagged then - Append_Elmt (Old_C, Assoc_List); - Append_Elmt (New_C, Assoc_List); + Bound := Type_High_Bound (T); + + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); end if; - end Inherit_Component; - -- Variables local to Inherit_Component + else + Set_Scalar_Range (T, Scalar_Range (Base_Typ)); + end if; - Loc : constant Source_Ptr := Sloc (N); + -- Complete definition of implicit base and declared first subtype - Parent_Discrim : Entity_Id; - Stored_Discrim : Entity_Id; - D : Entity_Id; - Component : Entity_Id; + Set_Etype (Implicit_Base, Base_Typ); - -- Start of processing for Inherit_Components + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); + Set_Size_Info (Implicit_Base, (Base_Typ)); + Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); + Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - begin - if not Is_Tagged then - Append_Elmt (Parent_Base, Assoc_List); - Append_Elmt (Derived_Base, Assoc_List); - end if; + Set_Ekind (T, E_Floating_Point_Subtype); + Set_Etype (T, Implicit_Base); - -- Inherit parent discriminants if needed + Set_Size_Info (T, (Implicit_Base)); + Set_RM_Size (T, RM_Size (Implicit_Base)); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + end Floating_Point_Type_Declaration; - if Inherit_Discr then - Parent_Discrim := First_Discriminant (Parent_Base); - while Present (Parent_Discrim) loop - Inherit_Component (Parent_Discrim, Plain_Discrim => True); - Next_Discriminant (Parent_Discrim); - end loop; - end if; + ---------------------------- + -- Get_Discriminant_Value -- + ---------------------------- - -- Create explicit stored discrims for untagged types when necessary + -- This is the situation: - if not Has_Unknown_Discriminants (Derived_Base) - and then Has_Discriminants (Parent_Base) - and then not Is_Tagged - and then - (not Inherit_Discr - or else First_Discriminant (Parent_Base) /= - First_Stored_Discriminant (Parent_Base)) - then - Stored_Discrim := First_Stored_Discriminant (Parent_Base); - while Present (Stored_Discrim) loop - Inherit_Component (Stored_Discrim, Stored_Discrim => True); - Next_Stored_Discriminant (Stored_Discrim); - end loop; - end if; + -- There is a non-derived type - -- See if we can apply the second transformation for derived types, as - -- explained in point 6. in the comments above Build_Derived_Record_Type - -- This is achieved by appending Derived_Base discriminants into Discs, - -- which has the side effect of returning a non empty Discs list to the - -- caller of Inherit_Components, which is what we want. This must be - -- done for private derived types if there are explicit stored - -- discriminants, to ensure that we can retrieve the values of the - -- constraints provided in the ancestors. + -- type T0 (Dx, Dy, Dz...) - if Inherit_Discr - and then Is_Empty_Elmt_List (Discs) - and then Present (First_Discriminant (Derived_Base)) - and then - (not Is_Private_Type (Derived_Base) - or else Is_Completely_Hidden - (First_Stored_Discriminant (Derived_Base)) - or else Is_Generic_Type (Derived_Base)) - then - D := First_Discriminant (Derived_Base); - while Present (D) loop - Append_Elmt (New_Occurrence_Of (D, Loc), Discs); - Next_Discriminant (D); - end loop; - end if; + -- There are zero or more levels of derivation, with each derivation + -- either purely inheriting the discriminants, or defining its own. - -- Finally, inherit non-discriminant components unless they are not - -- visible because defined or inherited from the full view of the - -- parent. Don't inherit the _parent field of the parent type. + -- type Ti is new Ti-1 + -- or + -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) + -- or + -- subtype Ti is ... - Component := First_Entity (Parent_Base); - while Present (Component) loop + -- The subtype issue is avoided by the use of Original_Record_Component, + -- and the fact that derived subtypes also derive the constraints. - -- Ada 2005 (AI-251): Do not inherit components associated with - -- secondary tags of the parent. + -- This chain leads back from - if Ekind (Component) = E_Component - and then Present (Related_Type (Component)) - then - null; + -- Typ_For_Constraint - elsif Ekind (Component) /= E_Component - or else Chars (Component) = Name_uParent - then - null; + -- Typ_For_Constraint has discriminants, and the value for each + -- discriminant is given by its corresponding Elmt of Constraints. - -- If the derived type is within the parent type's declarative - -- region, then the components can still be inherited even though - -- they aren't visible at this point. This can occur for cases - -- such as within public child units where the components must - -- become visible upon entering the child unit's private part. + -- Discriminant is some discriminant in this hierarchy - elsif not Is_Visible_Component (Component) - and then not In_Open_Scopes (Scope (Parent_Base)) - then - null; + -- We need to return its value - elsif Ekind_In (Derived_Base, E_Private_Type, - E_Limited_Private_Type) - then - null; + -- We do this by recursively searching each level, and looking for + -- Discriminant. Once we get to the bottom, we start backing up + -- returning the value for it which may in turn be a discriminant + -- further up, so on the backup we continue the substitution. - else - Inherit_Component (Component); - end if; + function Get_Discriminant_Value + (Discriminant : Entity_Id; + Typ_For_Constraint : Entity_Id; + Constraint : Elist_Id) return Node_Id + is + function Root_Corresponding_Discriminant + (Discr : Entity_Id) return Entity_Id; + -- Given a discriminant, traverse the chain of inherited discriminants + -- and return the topmost discriminant. - Next_Entity (Component); - end loop; + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; + -- This is the routine that performs the recursive search of levels + -- as described above. - -- For tagged derived types, inherited discriminants cannot be used in - -- component declarations of the record extension part. To achieve this - -- we mark the inherited discriminants as not visible. + ------------------------------------- + -- Root_Corresponding_Discriminant -- + ------------------------------------- - if Is_Tagged and then Inherit_Discr then - D := First_Discriminant (Derived_Base); - while Present (D) loop - Set_Is_Immediately_Visible (D, False); - Next_Discriminant (D); + function Root_Corresponding_Discriminant + (Discr : Entity_Id) return Entity_Id + is + D : Entity_Id; + + begin + D := Discr; + while Present (Corresponding_Discriminant (D)) loop + D := Corresponding_Discriminant (D); end loop; - end if; - return Assoc_List; - end Inherit_Components; + return D; + end Root_Corresponding_Discriminant; - ----------------------------- - -- Inherit_Predicate_Flags -- - ----------------------------- + ------------------------------ + -- Search_Derivation_Levels -- + ------------------------------ - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is - begin - Set_Has_Predicates (Subt, Has_Predicates (Par)); - Set_Has_Static_Predicate_Aspect - (Subt, Has_Static_Predicate_Aspect (Par)); - Set_Has_Dynamic_Predicate_Aspect - (Subt, Has_Dynamic_Predicate_Aspect (Par)); - end Inherit_Predicate_Flags; + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id + is + Assoc : Elmt_Id; + Disc : Entity_Id; + Result : Node_Or_Entity_Id; + Result_Entity : Node_Id; - ----------------------- - -- Is_Null_Extension -- - ----------------------- + begin + -- If inappropriate type, return Error, this happens only in + -- cascaded error situations, and we want to avoid a blow up. - function Is_Null_Extension (T : Entity_Id) return Boolean is - Type_Decl : constant Node_Id := Parent (Base_Type (T)); - Comp_List : Node_Id; - Comp : Node_Id; + if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then + return Error; + end if; - begin - if Nkind (Type_Decl) /= N_Full_Type_Declaration - or else not Is_Tagged_Type (T) - or else Nkind (Type_Definition (Type_Decl)) /= - N_Derived_Type_Definition - or else No (Record_Extension_Part (Type_Definition (Type_Decl))) - then - return False; - end if; + -- Look deeper if possible. Use Stored_Constraints only for + -- untagged types. For tagged types use the given constraint. + -- This asymmetry needs explanation??? - Comp_List := - Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); + if not Stored_Discrim_Values + and then Present (Stored_Constraint (Ti)) + and then not Is_Tagged_Type (Ti) + then + Result := + Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); + else + declare + Td : constant Entity_Id := Etype (Ti); - if Present (Discriminant_Specifications (Type_Decl)) then - return False; + begin + if Td = Ti then + Result := Discriminant; - elsif Present (Comp_List) - and then Is_Non_Empty_List (Component_Items (Comp_List)) - then - Comp := First (Component_Items (Comp_List)); + else + if Present (Stored_Constraint (Ti)) then + Result := + Search_Derivation_Levels + (Td, Stored_Constraint (Ti), True); + else + Result := + Search_Derivation_Levels + (Td, Discrim_Values, Stored_Discrim_Values); + end if; + end if; + end; + end if; - -- Only user-defined components are relevant. The component list - -- may also contain a parent component and internal components - -- corresponding to secondary tags, but these do not determine - -- whether this is a null extension. + -- Extra underlying places to search, if not found above. For + -- concurrent types, the relevant discriminant appears in the + -- corresponding record. For a type derived from a private type + -- without discriminant, the full view inherits the discriminants + -- of the full view of the parent. - while Present (Comp) loop - if Comes_From_Source (Comp) then - return False; + if Result = Discriminant then + if Is_Concurrent_Type (Ti) + and then Present (Corresponding_Record_Type (Ti)) + then + Result := + Search_Derivation_Levels ( + Corresponding_Record_Type (Ti), + Discrim_Values, + Stored_Discrim_Values); + + elsif Is_Private_Type (Ti) + and then not Has_Discriminants (Ti) + and then Present (Full_View (Ti)) + and then Etype (Full_View (Ti)) /= Ti + then + Result := + Search_Derivation_Levels ( + Full_View (Ti), + Discrim_Values, + Stored_Discrim_Values); end if; + end if; - Next (Comp); - end loop; - - return True; - else - return True; - end if; - end Is_Null_Extension; + -- If Result is not a (reference to a) discriminant, return it, + -- otherwise set Result_Entity to the discriminant. - ------------------------------ - -- Is_Valid_Constraint_Kind -- - ------------------------------ + if Nkind (Result) = N_Defining_Identifier then + pragma Assert (Result = Discriminant); + Result_Entity := Result; - function Is_Valid_Constraint_Kind - (T_Kind : Type_Kind; - Constraint_Kind : Node_Kind) return Boolean - is - begin - case T_Kind is - when Enumeration_Kind | - Integer_Kind => - return Constraint_Kind = N_Range_Constraint; + else + if not Denotes_Discriminant (Result) then + return Result; + end if; - when Decimal_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + Result_Entity := Entity (Result); + end if; - when Ordinary_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Delta_Constraint, - N_Range_Constraint); + -- See if this level of derivation actually has discriminants + -- because tagged derivations can add them, hence the lower + -- levels need not have any. - when Float_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + if not Has_Discriminants (Ti) then + return Result; + end if; - when Access_Kind | - Array_Kind | - E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type | - Private_Kind | - Concurrent_Kind => - return Constraint_Kind = N_Index_Or_Discriminant_Constraint; + -- Scan Ti's discriminants for Result_Entity, + -- and return its corresponding value, if any. - when others => - return True; -- Error will be detected later - end case; - end Is_Valid_Constraint_Kind; + Result_Entity := Original_Record_Component (Result_Entity); - -------------------------- - -- Is_Visible_Component -- - -------------------------- + Assoc := First_Elmt (Discrim_Values); - function Is_Visible_Component - (C : Entity_Id; - N : Node_Id := Empty) return Boolean - is - Original_Comp : Entity_Id := Empty; - Original_Scope : Entity_Id; - Type_Scope : Entity_Id; + if Stored_Discrim_Values then + Disc := First_Stored_Discriminant (Ti); + else + Disc := First_Discriminant (Ti); + end if; - function Is_Local_Type (Typ : Entity_Id) return Boolean; - -- Check whether parent type of inherited component is declared locally, - -- possibly within a nested package or instance. The current scope is - -- the derived record itself. + while Present (Disc) loop + pragma Assert (Present (Assoc)); - ------------------- - -- Is_Local_Type -- - ------------------- + if Original_Record_Component (Disc) = Result_Entity then + return Node (Assoc); + end if; - function Is_Local_Type (Typ : Entity_Id) return Boolean is - Scop : Entity_Id; + Next_Elmt (Assoc); - begin - Scop := Scope (Typ); - while Present (Scop) - and then Scop /= Standard_Standard - loop - if Scop = Scope (Current_Scope) then - return True; + if Stored_Discrim_Values then + Next_Stored_Discriminant (Disc); + else + Next_Discriminant (Disc); end if; - - Scop := Scope (Scop); end loop; - return False; - end Is_Local_Type; - - -- Start of processing for Is_Visible_Component - - begin - if Ekind_In (C, E_Component, E_Discriminant) then - Original_Comp := Original_Record_Component (C); - end if; - - if No (Original_Comp) then - - -- Premature usage, or previous error + -- Could not find it + -- + return Result; + end Search_Derivation_Levels; - return False; + -- Local Variables - else - Original_Scope := Scope (Original_Comp); - Type_Scope := Scope (Base_Type (Scope (C))); - end if; + Result : Node_Or_Entity_Id; - -- This test only concerns tagged types + -- Start of processing for Get_Discriminant_Value - if not Is_Tagged_Type (Original_Scope) then - return True; + begin + -- ??? This routine is a gigantic mess and will be deleted. For the + -- time being just test for the trivial case before calling recurse. - -- If it is _Parent or _Tag, there is no visibility issue + if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then + declare + D : Entity_Id; + E : Elmt_Id; - elsif not Comes_From_Source (Original_Comp) then - return True; + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Chars (D) = Chars (Discriminant) then + return Node (E); + end if; - -- Discriminants are visible unless the (private) type has unknown - -- discriminants. If the discriminant reference is inserted for a - -- discriminant check on a full view it is also visible. + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; + end if; - elsif Ekind (Original_Comp) = E_Discriminant - and then - (not Has_Unknown_Discriminants (Original_Scope) - or else (Present (N) - and then Nkind (N) = N_Selected_Component - and then Nkind (Prefix (N)) = N_Type_Conversion - and then not Comes_From_Source (Prefix (N)))) - then - return True; + Result := Search_Derivation_Levels + (Typ_For_Constraint, Constraint, False); - -- In the body of an instantiation, no need to check for the visibility - -- of a component. + -- ??? hack to disappear when this routine is gone - elsif In_Instance_Body then - return True; + if Nkind (Result) = N_Defining_Identifier then + declare + D : Entity_Id; + E : Elmt_Id; - -- If the component has been declared in an ancestor which is currently - -- a private type, then it is not visible. The same applies if the - -- component's containing type is not in an open scope and the original - -- component's enclosing type is a visible full view of a private type - -- (which can occur in cases where an attempt is being made to reference - -- a component in a sibling package that is inherited from a visible - -- component of a type in an ancestor package; the component in the - -- sibling package should not be visible even though the component it - -- inherited from is visible). This does not apply however in the case - -- where the scope of the type is a private child unit, or when the - -- parent comes from a local package in which the ancestor is currently - -- visible. The latter suppression of visibility is needed for cases - -- that are tested in B730006. + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Root_Corresponding_Discriminant (D) = Discriminant then + return Node (E); + end if; - elsif Is_Private_Type (Original_Scope) - or else - (not Is_Private_Descendant (Type_Scope) - and then not In_Open_Scopes (Type_Scope) - and then Has_Private_Declaration (Original_Scope)) - then - -- If the type derives from an entity in a formal package, there - -- are no additional visible components. + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; + end if; - if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = - N_Formal_Package_Declaration - then - return False; + pragma Assert (Nkind (Result) /= N_Defining_Identifier); + return Result; + end Get_Discriminant_Value; - -- if we are not in the private part of the current package, there - -- are no additional visible components. + -------------------------- + -- Has_Range_Constraint -- + -------------------------- - elsif Ekind (Scope (Current_Scope)) = E_Package - and then not In_Private_Part (Scope (Current_Scope)) - then - return False; - else - return - Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) - and then In_Open_Scopes (Scope (Original_Scope)) - and then Is_Local_Type (Type_Scope); - end if; + function Has_Range_Constraint (N : Node_Id) return Boolean is + C : constant Node_Id := Constraint (N); - -- There is another weird way in which a component may be invisible when - -- the private and the full view are not derived from the same ancestor. - -- Here is an example : + begin + if Nkind (C) = N_Range_Constraint then + return True; - -- type A1 is tagged record F1 : integer; end record; - -- type A2 is new A1 with record F2 : integer; end record; - -- type T is new A1 with private; - -- private - -- type T is new A2 with null record; + elsif Nkind (C) = N_Digits_Constraint then + return + Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) + or else + Present (Range_Constraint (C)); - -- In this case, the full view of T inherits F1 and F2 but the private - -- view inherits only F1 + elsif Nkind (C) = N_Delta_Constraint then + return Present (Range_Constraint (C)); else - declare - Ancestor : Entity_Id := Scope (C); + return False; + end if; + end Has_Range_Constraint; - begin - loop - if Ancestor = Original_Scope then - return True; - elsif Ancestor = Etype (Ancestor) then - return False; - end if; + ------------------------ + -- Inherit_Components -- + ------------------------ - Ancestor := Etype (Ancestor); - end loop; - end; - end if; - end Is_Visible_Component; + function Inherit_Components + (N : Node_Id; + Parent_Base : Entity_Id; + Derived_Base : Entity_Id; + Is_Tagged : Boolean; + Inherit_Discr : Boolean; + Discs : Elist_Id) return Elist_Id + is + Assoc_List : constant Elist_Id := New_Elmt_List; - -------------------------- - -- Make_Class_Wide_Type -- - -------------------------- + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False); + -- Inherits component Old_C from Parent_Base to the Derived_Base. If + -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is + -- True, Old_C is a stored discriminant. If they are both false then + -- Old_C is a regular component. - procedure Make_Class_Wide_Type (T : Entity_Id) is - CW_Type : Entity_Id; - CW_Name : Name_Id; - Next_E : Entity_Id; + ----------------------- + -- Inherit_Component -- + ----------------------- - begin - if Present (Class_Wide_Type (T)) then + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False) + is + procedure Set_Anonymous_Type (Id : Entity_Id); + -- Id denotes the entity of an access discriminant or anonymous + -- access component. Set the type of Id to either the same type of + -- Old_C or create a new one depending on whether the parent and + -- the child types are in the same scope. - -- The class-wide type is a partially decorated entity created for a - -- unanalyzed tagged type referenced through a limited with clause. - -- When the tagged type is analyzed, its class-wide type needs to be - -- redecorated. Note that we reuse the entity created by Decorate_ - -- Tagged_Type in order to preserve all links. + ------------------------ + -- Set_Anonymous_Type -- + ------------------------ - if Materialize_Entity (Class_Wide_Type (T)) then - CW_Type := Class_Wide_Type (T); - Set_Materialize_Entity (CW_Type, False); + procedure Set_Anonymous_Type (Id : Entity_Id) is + Old_Typ : constant Entity_Id := Etype (Old_C); - -- The class wide type can have been defined by the partial view, in - -- which case everything is already done. + begin + if Scope (Parent_Base) = Scope (Derived_Base) then + Set_Etype (Id, Old_Typ); - else - return; - end if; + -- The parent and the derived type are in two different scopes. + -- Reuse the type of the original discriminant / component by + -- copying it in order to preserve all attributes. - -- Default case, we need to create a new class-wide type + else + declare + Typ : constant Entity_Id := New_Copy (Old_Typ); - else - CW_Type := - New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); - end if; + begin + Set_Etype (Id, Typ); - -- Inherit root type characteristics + -- Since we do not generate component declarations for + -- inherited components, associate the itype with the + -- derived type. - CW_Name := Chars (CW_Type); - Next_E := Next_Entity (CW_Type); - Copy_Node (T, CW_Type); - Set_Comes_From_Source (CW_Type, False); - Set_Chars (CW_Type, CW_Name); - Set_Parent (CW_Type, Parent (T)); - Set_Next_Entity (CW_Type, Next_E); + Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); + Set_Scope (Typ, Derived_Base); + end; + end if; + end Set_Anonymous_Type; - -- Ensure we have a new freeze node for the class-wide type. The partial - -- view may have freeze action of its own, requiring a proper freeze - -- node, and the same freeze node cannot be shared between the two - -- types. + -- Local variables and constants - Set_Has_Delayed_Freeze (CW_Type); - Set_Freeze_Node (CW_Type, Empty); + New_C : constant Entity_Id := New_Copy (Old_C); - -- Customize the class-wide type: It has no prim. op., it cannot be - -- abstract and its Etype points back to the specific root type. + Corr_Discrim : Entity_Id; + Discrim : Entity_Id; - Set_Ekind (CW_Type, E_Class_Wide_Type); - Set_Is_Tagged_Type (CW_Type, True); - Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); - Set_Is_Abstract_Type (CW_Type, False); - Set_Is_Constrained (CW_Type, False); - Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); - Set_Default_SSO (CW_Type); + -- Start of processing for Inherit_Component - if Ekind (T) = E_Class_Wide_Subtype then - Set_Etype (CW_Type, Etype (Base_Type (T))); - else - Set_Etype (CW_Type, T); - end if; + begin + pragma Assert (not Is_Tagged or else not Stored_Discrim); - -- If this is the class_wide type of a constrained subtype, it does - -- not have discriminants. + Set_Parent (New_C, Parent (Old_C)); - Set_Has_Discriminants (CW_Type, - Has_Discriminants (T) and then not Is_Constrained (T)); + -- Regular discriminants and components must be inserted in the scope + -- of the Derived_Base. Do it here. - Set_Has_Unknown_Discriminants (CW_Type, True); - Set_Class_Wide_Type (T, CW_Type); - Set_Equivalent_Type (CW_Type, Empty); + if not Stored_Discrim then + Enter_Name (New_C); + end if; - -- The class-wide type of a class-wide type is itself (RM 3.9(14)) + -- For tagged types the Original_Record_Component must point to + -- whatever this field was pointing to in the parent type. This has + -- already been achieved by the call to New_Copy above. - Set_Class_Wide_Type (CW_Type, CW_Type); - end Make_Class_Wide_Type; + if not Is_Tagged then + Set_Original_Record_Component (New_C, New_C); + end if; - ---------------- - -- Make_Index -- - ---------------- + -- Set the proper type of an access discriminant - procedure Make_Index - (N : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1; - In_Iter_Schm : Boolean := False) - is - R : Node_Id; - T : Entity_Id; - Def_Id : Entity_Id := Empty; - Found : Boolean := False; + if Ekind (New_C) = E_Discriminant + and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type + then + Set_Anonymous_Type (New_C); + end if; - begin - -- For a discrete range used in a constrained array definition and - -- defined by a range, an implicit conversion to the predefined type - -- INTEGER is assumed if each bound is either a numeric literal, a named - -- number, or an attribute, and the type of both bounds (prior to the - -- implicit conversion) is the type universal_integer. Otherwise, both - -- bounds must be of the same discrete type, other than universal - -- integer; this type must be determinable independently of the - -- context, but using the fact that the type must be discrete and that - -- both bounds must have the same type. + -- If we have inherited a component then see if its Etype contains + -- references to Parent_Base discriminants. In this case, replace + -- these references with the constraints given in Discs. We do not + -- do this for the partial view of private types because this is + -- not needed (only the components of the full view will be used + -- for code generation) and cause problem. We also avoid this + -- transformation in some error situations. - -- Character literals also have a universal type in the absence of - -- of additional context, and are resolved to Standard_Character. + if Ekind (New_C) = E_Component then - if Nkind (N) = N_Range then + -- Set the proper type of an anonymous access component - -- The index is given by a range constraint. The bounds are known - -- to be of a consistent type. + if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then + Set_Anonymous_Type (New_C); - if not Is_Overloaded (N) then - T := Etype (N); + elsif (Is_Private_Type (Derived_Base) + and then not Is_Generic_Type (Derived_Base)) + or else (Is_Empty_Elmt_List (Discs) + and then not Expander_Active) + then + Set_Etype (New_C, Etype (Old_C)); - -- For universal bounds, choose the specific predefined type + else + -- The current component introduces a circularity of the + -- following kind: - if T = Universal_Integer then - T := Standard_Integer; + -- limited with Pack_2; + -- package Pack_1 is + -- type T_1 is tagged record + -- Comp : access Pack_2.T_2; + -- ... + -- end record; + -- end Pack_1; - elsif T = Any_Character then - Ambiguous_Character (Low_Bound (N)); + -- with Pack_1; + -- package Pack_2 is + -- type T_2 is new Pack_1.T_1 with ...; + -- end Pack_2; + + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Derived_Base, N, Parent_Base, Discs)); + end if; + end if; + + -- In derived tagged types it is illegal to reference a non + -- discriminant component in the parent type. To catch this, mark + -- these components with an Ekind of E_Void. This will be reset in + -- Record_Type_Definition after processing the record extension of + -- the derived type. + + -- If the declaration is a private extension, there is no further + -- record extension to process, and the components retain their + -- current kind, because they are visible at this point. - T := Standard_Character; - end if; + if Is_Tagged and then Ekind (New_C) = E_Component + and then Nkind (N) /= N_Private_Extension_Declaration + then + Set_Ekind (New_C, E_Void); + end if; - -- The node may be overloaded because some user-defined operators - -- are available, but if a universal interpretation exists it is - -- also the selected one. + if Plain_Discrim then + Set_Corresponding_Discriminant (New_C, Old_C); + Build_Discriminal (New_C); - elsif Universal_Interpretation (N) = Universal_Integer then - T := Standard_Integer; + -- If we are explicitly inheriting a stored discriminant it will be + -- completely hidden. - else - T := Any_Type; + elsif Stored_Discrim then + Set_Corresponding_Discriminant (New_C, Empty); + Set_Discriminal (New_C, Empty); + Set_Is_Completely_Hidden (New_C); - declare - Ind : Interp_Index; - It : Interp; + -- Set the Original_Record_Component of each discriminant in the + -- derived base to point to the corresponding stored that we just + -- created. - begin - Get_First_Interp (N, Ind, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then + Discrim := First_Discriminant (Derived_Base); + while Present (Discrim) loop + Corr_Discrim := Corresponding_Discriminant (Discrim); - if Found - and then not Covers (It.Typ, T) - and then not Covers (T, It.Typ) - then - Error_Msg_N ("ambiguous bounds in discrete range", N); - exit; - else - T := It.Typ; - Found := True; - end if; - end if; + -- Corr_Discrim could be missing in an error situation - Get_Next_Interp (Ind, It); - end loop; + if Present (Corr_Discrim) + and then Original_Record_Component (Corr_Discrim) = Old_C + then + Set_Original_Record_Component (Discrim, New_C); + end if; - if T = Any_Type then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; + Next_Discriminant (Discrim); + end loop; - elsif T = Universal_Integer then - T := Standard_Integer; - end if; - end; + Append_Entity (New_C, Derived_Base); end if; - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; + if not Is_Tagged then + Append_Elmt (Old_C, Assoc_List); + Append_Elmt (New_C, Assoc_List); end if; + end Inherit_Component; - if Nkind (Low_Bound (N)) = N_Attribute_Reference - and then Attribute_Name (Low_Bound (N)) = Name_First - and then Is_Entity_Name (Prefix (Low_Bound (N))) - and then Is_Type (Entity (Prefix (Low_Bound (N)))) - and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) - then - -- The type of the index will be the type of the prefix, as long - -- as the upper bound is 'Last of the same type. + -- Variables local to Inherit_Component - Def_Id := Entity (Prefix (Low_Bound (N))); + Loc : constant Source_Ptr := Sloc (N); - if Nkind (High_Bound (N)) /= N_Attribute_Reference - or else Attribute_Name (High_Bound (N)) /= Name_Last - or else not Is_Entity_Name (Prefix (High_Bound (N))) - or else Entity (Prefix (High_Bound (N))) /= Def_Id - then - Def_Id := Empty; - end if; - end if; + Parent_Discrim : Entity_Id; + Stored_Discrim : Entity_Id; + D : Entity_Id; + Component : Entity_Id; - R := N; - Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); + -- Start of processing for Inherit_Components - elsif Nkind (N) = N_Subtype_Indication then + begin + if not Is_Tagged then + Append_Elmt (Parent_Base, Assoc_List); + Append_Elmt (Derived_Base, Assoc_List); + end if; - -- The index is given by a subtype with a range constraint + -- Inherit parent discriminants if needed - T := Base_Type (Entity (Subtype_Mark (N))); + if Inherit_Discr then + Parent_Discrim := First_Discriminant (Parent_Base); + while Present (Parent_Discrim) loop + Inherit_Component (Parent_Discrim, Plain_Discrim => True); + Next_Discriminant (Parent_Discrim); + end loop; + end if; - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; - end if; + -- Create explicit stored discrims for untagged types when necessary - R := Range_Expression (Constraint (N)); + if not Has_Unknown_Discriminants (Derived_Base) + and then Has_Discriminants (Parent_Base) + and then not Is_Tagged + and then + (not Inherit_Discr + or else First_Discriminant (Parent_Base) /= + First_Stored_Discriminant (Parent_Base)) + then + Stored_Discrim := First_Stored_Discriminant (Parent_Base); + while Present (Stored_Discrim) loop + Inherit_Component (Stored_Discrim, Stored_Discrim => True); + Next_Stored_Discriminant (Stored_Discrim); + end loop; + end if; - Resolve (R, T); - Process_Range_Expr_In_Decl - (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); + -- See if we can apply the second transformation for derived types, as + -- explained in point 6. in the comments above Build_Derived_Record_Type + -- This is achieved by appending Derived_Base discriminants into Discs, + -- which has the side effect of returning a non empty Discs list to the + -- caller of Inherit_Components, which is what we want. This must be + -- done for private derived types if there are explicit stored + -- discriminants, to ensure that we can retrieve the values of the + -- constraints provided in the ancestors. - elsif Nkind (N) = N_Attribute_Reference then + if Inherit_Discr + and then Is_Empty_Elmt_List (Discs) + and then Present (First_Discriminant (Derived_Base)) + and then + (not Is_Private_Type (Derived_Base) + or else Is_Completely_Hidden + (First_Stored_Discriminant (Derived_Base)) + or else Is_Generic_Type (Derived_Base)) + then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Append_Elmt (New_Occurrence_Of (D, Loc), Discs); + Next_Discriminant (D); + end loop; + end if; - -- Catch beginner's error (use of attribute other than 'Range) + -- Finally, inherit non-discriminant components unless they are not + -- visible because defined or inherited from the full view of the + -- parent. Don't inherit the _parent field of the parent type. - if Attribute_Name (N) /= Name_Range then - Error_Msg_N ("expect attribute ''Range", N); - Set_Etype (N, Any_Type); - return; - end if; + Component := First_Entity (Parent_Base); + while Present (Component) loop - -- If the node denotes the range of a type mark, that is also the - -- resulting type, and we do not need to create an Itype for it. + -- Ada 2005 (AI-251): Do not inherit components associated with + -- secondary tags of the parent. - if Is_Entity_Name (Prefix (N)) - and then Comes_From_Source (N) - and then Is_Type (Entity (Prefix (N))) - and then Is_Discrete_Type (Entity (Prefix (N))) + if Ekind (Component) = E_Component + and then Present (Related_Type (Component)) then - Def_Id := Entity (Prefix (N)); - end if; + null; - Analyze_And_Resolve (N); - T := Etype (N); - R := N; + elsif Ekind (Component) /= E_Component + or else Chars (Component) = Name_uParent + then + null; - -- If none of the above, must be a subtype. We convert this to a - -- range attribute reference because in the case of declared first - -- named subtypes, the types in the range reference can be different - -- from the type of the entity. A range attribute normalizes the - -- reference and obtains the correct types for the bounds. + -- If the derived type is within the parent type's declarative + -- region, then the components can still be inherited even though + -- they aren't visible at this point. This can occur for cases + -- such as within public child units where the components must + -- become visible upon entering the child unit's private part. - -- This transformation is in the nature of an expansion, is only - -- done if expansion is active. In particular, it is not done on - -- formal generic types, because we need to retain the name of the - -- original index for instantiation purposes. + elsif not Is_Visible_Component (Component) + and then not In_Open_Scopes (Scope (Parent_Base)) + then + null; - else - if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then - Error_Msg_N ("invalid subtype mark in discrete range ", N); - Set_Etype (N, Any_Integer); - return; + elsif Ekind_In (Derived_Base, E_Private_Type, + E_Limited_Private_Type) + then + null; else - -- The type mark may be that of an incomplete type. It is only - -- now that we can get the full view, previous analysis does - -- not look specifically for a type mark. - - Set_Entity (N, Get_Full_View (Entity (N))); - Set_Etype (N, Entity (N)); - Def_Id := Entity (N); - - if not Is_Discrete_Type (Def_Id) then - Error_Msg_N ("discrete type required for index", N); - Set_Etype (N, Any_Type); - return; - end if; + Inherit_Component (Component); end if; - if Expander_Active then - Rewrite (N, - Make_Attribute_Reference (Sloc (N), - Attribute_Name => Name_Range, - Prefix => Relocate_Node (N))); + Next_Entity (Component); + end loop; - -- The original was a subtype mark that does not freeze. This - -- means that the rewritten version must not freeze either. + -- For tagged derived types, inherited discriminants cannot be used in + -- component declarations of the record extension part. To achieve this + -- we mark the inherited discriminants as not visible. + + if Is_Tagged and then Inherit_Discr then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Set_Is_Immediately_Visible (D, False); + Next_Discriminant (D); + end loop; + end if; - Set_Must_Not_Freeze (N); - Set_Must_Not_Freeze (Prefix (N)); - Analyze_And_Resolve (N); - T := Etype (N); - R := N; + return Assoc_List; + end Inherit_Components; - -- If expander is inactive, type is legal, nothing else to construct + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- - else - return; - end if; - end if; + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + begin + Set_Has_Predicates (Subt, Has_Predicates (Par)); + Set_Has_Static_Predicate_Aspect + (Subt, Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect + (Subt, Has_Dynamic_Predicate_Aspect (Par)); + end Inherit_Predicate_Flags; - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; + ----------------------- + -- Is_Null_Extension -- + ----------------------- - elsif T = Any_Type then - Set_Etype (N, Any_Type); - return; + function Is_Null_Extension (T : Entity_Id) return Boolean is + Type_Decl : constant Node_Id := Parent (Base_Type (T)); + Comp_List : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Type_Decl) /= N_Full_Type_Declaration + or else not Is_Tagged_Type (T) + or else Nkind (Type_Definition (Type_Decl)) /= + N_Derived_Type_Definition + or else No (Record_Extension_Part (Type_Definition (Type_Decl))) + then + return False; end if; - -- We will now create the appropriate Itype to describe the range, but - -- first a check. If we originally had a subtype, then we just label - -- the range with this subtype. Not only is there no need to construct - -- a new subtype, but it is wrong to do so for two reasons: + Comp_List := + Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); - -- 1. A legality concern, if we have a subtype, it must not freeze, - -- and the Itype would cause freezing incorrectly + if Present (Discriminant_Specifications (Type_Decl)) then + return False; - -- 2. An efficiency concern, if we created an Itype, it would not be - -- recognized as the same type for the purposes of eliminating - -- checks in some circumstances. + elsif Present (Comp_List) + and then Is_Non_Empty_List (Component_Items (Comp_List)) + then + Comp := First (Component_Items (Comp_List)); - -- We signal this case by setting the subtype entity in Def_Id + -- Only user-defined components are relevant. The component list + -- may also contain a parent component and internal components + -- corresponding to secondary tags, but these do not determine + -- whether this is a null extension. - if No (Def_Id) then - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); - Set_Etype (Def_Id, Base_Type (T)); + while Present (Comp) loop + if Comes_From_Source (Comp) then + return False; + end if; - if Is_Signed_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + Next (Comp); + end loop; - elsif Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + return True; + else + return True; + end if; + end Is_Null_Extension; - else - Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_First_Literal (Def_Id, First_Literal (T)); - end if; + ------------------------------ + -- Is_Valid_Constraint_Kind -- + ------------------------------ - Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + function Is_Valid_Constraint_Kind + (T_Kind : Type_Kind; + Constraint_Kind : Node_Kind) return Boolean + is + begin + case T_Kind is + when Enumeration_Kind | + Integer_Kind => + return Constraint_Kind = N_Range_Constraint; - Set_Scalar_Range (Def_Id, R); - Conditional_Delay (Def_Id, T); + when Decimal_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); - if Nkind (N) = N_Subtype_Indication then - Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); - end if; + when Ordinary_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Delta_Constraint, + N_Range_Constraint); - -- In the subtype indication case, if the immediate parent of the - -- new subtype is non-static, then the subtype we create is non- - -- static, even if its bounds are static. + when Float_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); - if Nkind (N) = N_Subtype_Indication - and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) - then - Set_Is_Non_Static_Subtype (Def_Id); - end if; - end if; + when Access_Kind | + Array_Kind | + E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type | + Private_Kind | + Concurrent_Kind => + return Constraint_Kind = N_Index_Or_Discriminant_Constraint; - -- Final step is to label the index with this constructed type + when others => + return True; -- Error will be detected later + end case; + end Is_Valid_Constraint_Kind; - Set_Etype (N, Def_Id); - end Make_Index; + -------------------------- + -- Is_Visible_Component -- + -------------------------- - ------------------------------ - -- Modular_Type_Declaration -- - ------------------------------ + function Is_Visible_Component + (C : Entity_Id; + N : Node_Id := Empty) return Boolean + is + Original_Comp : Entity_Id := Empty; + Original_Scope : Entity_Id; + Type_Scope : Entity_Id; - procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Mod_Expr : constant Node_Id := Expression (Def); - M_Val : Uint; + function Is_Local_Type (Typ : Entity_Id) return Boolean; + -- Check whether parent type of inherited component is declared locally, + -- possibly within a nested package or instance. The current scope is + -- the derived record itself. - procedure Set_Modular_Size (Bits : Int); - -- Sets RM_Size to Bits, and Esize to normal word size above this + ------------------- + -- Is_Local_Type -- + ------------------- - ---------------------- - -- Set_Modular_Size -- - ---------------------- + function Is_Local_Type (Typ : Entity_Id) return Boolean is + Scop : Entity_Id; - procedure Set_Modular_Size (Bits : Int) is begin - Set_RM_Size (T, UI_From_Int (Bits)); + Scop := Scope (Typ); + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Scop = Scope (Current_Scope) then + return True; + end if; - if Bits <= 8 then - Init_Esize (T, 8); + Scop := Scope (Scop); + end loop; - elsif Bits <= 16 then - Init_Esize (T, 16); + return False; + end Is_Local_Type; - elsif Bits <= 32 then - Init_Esize (T, 32); + -- Start of processing for Is_Visible_Component - else - Init_Esize (T, System_Max_Binary_Modulus_Power); - end if; + begin + if Ekind_In (C, E_Component, E_Discriminant) then + Original_Comp := Original_Record_Component (C); + end if; - if not Non_Binary_Modulus (T) - and then Esize (T) = RM_Size (T) - then - Set_Is_Known_Valid (T); - end if; - end Set_Modular_Size; + if No (Original_Comp) then - -- Start of processing for Modular_Type_Declaration + -- Premature usage, or previous error - begin - -- If the mod expression is (exactly) 2 * literal, where literal is - -- 64 or less,then almost certainly the * was meant to be **. Warn. + return False; - if Warn_On_Suspicious_Modulus_Value - and then Nkind (Mod_Expr) = N_Op_Multiply - and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal - and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 - and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal - and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 - then - Error_Msg_N - ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); + else + Original_Scope := Scope (Original_Comp); + Type_Scope := Scope (Base_Type (Scope (C))); end if; - -- Proceed with analysis of mod expression + -- This test only concerns tagged types - Analyze_And_Resolve (Mod_Expr, Any_Integer); - Set_Etype (T, T); - Set_Ekind (T, E_Modular_Integer_Type); - Init_Alignment (T); - Set_Is_Constrained (T); + if not Is_Tagged_Type (Original_Scope) then + return True; - if not Is_OK_Static_Expression (Mod_Expr) then - Flag_Non_Static_Expr - ("non-static expression used for modular type bound!", Mod_Expr); - M_Val := 2 ** System_Max_Binary_Modulus_Power; - else - M_Val := Expr_Value (Mod_Expr); - end if; + -- If it is _Parent or _Tag, there is no visibility issue + + elsif not Comes_From_Source (Original_Comp) then + return True; + + -- Discriminants are visible unless the (private) type has unknown + -- discriminants. If the discriminant reference is inserted for a + -- discriminant check on a full view it is also visible. + + elsif Ekind (Original_Comp) = E_Discriminant + and then + (not Has_Unknown_Discriminants (Original_Scope) + or else (Present (N) + and then Nkind (N) = N_Selected_Component + and then Nkind (Prefix (N)) = N_Type_Conversion + and then not Comes_From_Source (Prefix (N)))) + then + return True; - if M_Val < 1 then - Error_Msg_N ("modulus value must be positive", Mod_Expr); - M_Val := 2 ** System_Max_Binary_Modulus_Power; - end if; + -- In the body of an instantiation, no need to check for the visibility + -- of a component. - if M_Val > 2 ** Standard_Long_Integer_Size then - Check_Restriction (No_Long_Long_Integers, Mod_Expr); - end if; + elsif In_Instance_Body then + return True; - Set_Modulus (T, M_Val); + -- If the component has been declared in an ancestor which is currently + -- a private type, then it is not visible. The same applies if the + -- component's containing type is not in an open scope and the original + -- component's enclosing type is a visible full view of a private type + -- (which can occur in cases where an attempt is being made to reference + -- a component in a sibling package that is inherited from a visible + -- component of a type in an ancestor package; the component in the + -- sibling package should not be visible even though the component it + -- inherited from is visible). This does not apply however in the case + -- where the scope of the type is a private child unit, or when the + -- parent comes from a local package in which the ancestor is currently + -- visible. The latter suppression of visibility is needed for cases + -- that are tested in B730006. - -- Create bounds for the modular type based on the modulus given in - -- the type declaration and then analyze and resolve those bounds. + elsif Is_Private_Type (Original_Scope) + or else + (not Is_Private_Descendant (Type_Scope) + and then not In_Open_Scopes (Type_Scope) + and then Has_Private_Declaration (Original_Scope)) + then + -- If the type derives from an entity in a formal package, there + -- are no additional visible components. - Set_Scalar_Range (T, - Make_Range (Sloc (Mod_Expr), - Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), - High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); + if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = + N_Formal_Package_Declaration + then + return False; - -- Properly analyze the literals for the range. We do this manually - -- because we can't go calling Resolve, since we are resolving these - -- bounds with the type, and this type is certainly not complete yet. + -- if we are not in the private part of the current package, there + -- are no additional visible components. - Set_Etype (Low_Bound (Scalar_Range (T)), T); - Set_Etype (High_Bound (Scalar_Range (T)), T); - Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); - Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); + elsif Ekind (Scope (Current_Scope)) = E_Package + and then not In_Private_Part (Scope (Current_Scope)) + then + return False; + else + return + Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then In_Open_Scopes (Scope (Original_Scope)) + and then Is_Local_Type (Type_Scope); + end if; - -- Loop through powers of two to find number of bits required + -- There is another weird way in which a component may be invisible when + -- the private and the full view are not derived from the same ancestor. + -- Here is an example : - for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop + -- type A1 is tagged record F1 : integer; end record; + -- type A2 is new A1 with record F2 : integer; end record; + -- type T is new A1 with private; + -- private + -- type T is new A2 with null record; - -- Binary case + -- In this case, the full view of T inherits F1 and F2 but the private + -- view inherits only F1 - if M_Val = 2 ** Bits then - Set_Modular_Size (Bits); - return; + else + declare + Ancestor : Entity_Id := Scope (C); - -- Non-binary case + begin + loop + if Ancestor = Original_Scope then + return True; + elsif Ancestor = Etype (Ancestor) then + return False; + end if; - elsif M_Val < 2 ** Bits then - Check_SPARK_05_Restriction ("modulus should be a power of 2", T); - Set_Non_Binary_Modulus (T); + Ancestor := Etype (Ancestor); + end loop; + end; + end if; + end Is_Visible_Component; - if Bits > System_Max_Nonbinary_Modulus_Power then - Error_Msg_Uint_1 := - UI_From_Int (System_Max_Nonbinary_Modulus_Power); - Error_Msg_F - ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); - Set_Modular_Size (System_Max_Binary_Modulus_Power); - return; + -------------------------- + -- Make_Class_Wide_Type -- + -------------------------- - else - -- In the non-binary case, set size as per RM 13.3(55) + procedure Make_Class_Wide_Type (T : Entity_Id) is + CW_Type : Entity_Id; + CW_Name : Name_Id; + Next_E : Entity_Id; - Set_Modular_Size (Bits); - return; - end if; - end if; + begin + if Present (Class_Wide_Type (T)) then - end loop; + -- The class-wide type is a partially decorated entity created for a + -- unanalyzed tagged type referenced through a limited with clause. + -- When the tagged type is analyzed, its class-wide type needs to be + -- redecorated. Note that we reuse the entity created by Decorate_ + -- Tagged_Type in order to preserve all links. - -- If we fall through, then the size exceed System.Max_Binary_Modulus - -- so we just signal an error and set the maximum size. + if Materialize_Entity (Class_Wide_Type (T)) then + CW_Type := Class_Wide_Type (T); + Set_Materialize_Entity (CW_Type, False); - Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); - Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); + -- The class wide type can have been defined by the partial view, in + -- which case everything is already done. - Set_Modular_Size (System_Max_Binary_Modulus_Power); - Init_Alignment (T); + else + return; + end if; - end Modular_Type_Declaration; + -- Default case, we need to create a new class-wide type - -------------------------- - -- New_Concatenation_Op -- - -------------------------- + else + CW_Type := + New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + end if; - procedure New_Concatenation_Op (Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Op : Entity_Id; + -- Inherit root type characteristics - function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; - -- Create abbreviated declaration for the formal of a predefined - -- Operator 'Op' of type 'Typ' + CW_Name := Chars (CW_Type); + Next_E := Next_Entity (CW_Type); + Copy_Node (T, CW_Type); + Set_Comes_From_Source (CW_Type, False); + Set_Chars (CW_Type, CW_Name); + Set_Parent (CW_Type, Parent (T)); + Set_Next_Entity (CW_Type, Next_E); - -------------------- - -- Make_Op_Formal -- - -------------------- + -- Ensure we have a new freeze node for the class-wide type. The partial + -- view may have freeze action of its own, requiring a proper freeze + -- node, and the same freeze node cannot be shared between the two + -- types. - function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is - Formal : Entity_Id; - begin - Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); - Set_Etype (Formal, Typ); - Set_Mechanism (Formal, Default_Mechanism); - return Formal; - end Make_Op_Formal; + Set_Has_Delayed_Freeze (CW_Type); + Set_Freeze_Node (CW_Type, Empty); - -- Start of processing for New_Concatenation_Op + -- Customize the class-wide type: It has no prim. op., it cannot be + -- abstract and its Etype points back to the specific root type. - begin - Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); + Set_Ekind (CW_Type, E_Class_Wide_Type); + Set_Is_Tagged_Type (CW_Type, True); + Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); + Set_Is_Abstract_Type (CW_Type, False); + Set_Is_Constrained (CW_Type, False); + Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + Set_Default_SSO (CW_Type); - Set_Ekind (Op, E_Operator); - Set_Scope (Op, Current_Scope); - Set_Etype (Op, Typ); - Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); - Set_Is_Immediately_Visible (Op); - Set_Is_Intrinsic_Subprogram (Op); - Set_Has_Completion (Op); - Append_Entity (Op, Current_Scope); + if Ekind (T) = E_Class_Wide_Subtype then + Set_Etype (CW_Type, Etype (Base_Type (T))); + else + Set_Etype (CW_Type, T); + end if; - Set_Name_Entity_Id (Name_Op_Concat, Op); + -- If this is the class_wide type of a constrained subtype, it does + -- not have discriminants. - Append_Entity (Make_Op_Formal (Typ, Op), Op); - Append_Entity (Make_Op_Formal (Typ, Op), Op); - end New_Concatenation_Op; + Set_Has_Discriminants (CW_Type, + Has_Discriminants (T) and then not Is_Constrained (T)); - ------------------------- - -- OK_For_Limited_Init -- - ------------------------- + Set_Has_Unknown_Discriminants (CW_Type, True); + Set_Class_Wide_Type (T, CW_Type); + Set_Equivalent_Type (CW_Type, Empty); - -- ???Check all calls of this, and compare the conditions under which it's - -- called. + -- The class-wide type of a class-wide type is itself (RM 3.9(14)) - function OK_For_Limited_Init - (Typ : Entity_Id; - Exp : Node_Id) return Boolean - is - begin - return Is_CPP_Constructor_Call (Exp) - or else (Ada_Version >= Ada_2005 - and then not Debug_Flag_Dot_L - and then OK_For_Limited_Init_In_05 (Typ, Exp)); - end OK_For_Limited_Init; + Set_Class_Wide_Type (CW_Type, CW_Type); + end Make_Class_Wide_Type; - ------------------------------- - -- OK_For_Limited_Init_In_05 -- - ------------------------------- + ---------------- + -- Make_Index -- + ---------------- - function OK_For_Limited_Init_In_05 - (Typ : Entity_Id; - Exp : Node_Id) return Boolean + procedure Make_Index + (N : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix_Index : Nat := 1; + In_Iter_Schm : Boolean := False) is + R : Node_Id; + T : Entity_Id; + Def_Id : Entity_Id := Empty; + Found : Boolean := False; + begin - -- An object of a limited interface type can be initialized with any - -- expression of a nonlimited descendant type. + -- For a discrete range used in a constrained array definition and + -- defined by a range, an implicit conversion to the predefined type + -- INTEGER is assumed if each bound is either a numeric literal, a named + -- number, or an attribute, and the type of both bounds (prior to the + -- implicit conversion) is the type universal_integer. Otherwise, both + -- bounds must be of the same discrete type, other than universal + -- integer; this type must be determinable independently of the + -- context, but using the fact that the type must be discrete and that + -- both bounds must have the same type. - if Is_Class_Wide_Type (Typ) - and then Is_Limited_Interface (Typ) - and then not Is_Limited_Type (Etype (Exp)) - then - return True; - end if; + -- Character literals also have a universal type in the absence of + -- of additional context, and are resolved to Standard_Character. - -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in - -- case of limited aggregates (including extension aggregates), and - -- function calls. The function call may have been given in prefixed - -- notation, in which case the original node is an indexed component. - -- If the function is parameterless, the original node was an explicit - -- dereference. The function may also be parameterless, in which case - -- the source node is just an identifier. + if Nkind (N) = N_Range then - case Nkind (Original_Node (Exp)) is - when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => - return True; + -- The index is given by a range constraint. The bounds are known + -- to be of a consistent type. - when N_Identifier => - return Present (Entity (Original_Node (Exp))) - and then Ekind (Entity (Original_Node (Exp))) = E_Function; + if not Is_Overloaded (N) then + T := Etype (N); - when N_Qualified_Expression => - return - OK_For_Limited_Init_In_05 - (Typ, Expression (Original_Node (Exp))); + -- For universal bounds, choose the specific predefined type - -- Ada 2005 (AI-251): If a class-wide interface object is initialized - -- with a function call, the expander has rewritten the call into an - -- N_Type_Conversion node to force displacement of the pointer to - -- reference the component containing the secondary dispatch table. - -- Otherwise a type conversion is not a legal context. - -- A return statement for a build-in-place function returning a - -- synchronized type also introduces an unchecked conversion. + if T = Universal_Integer then + T := Standard_Integer; - when N_Type_Conversion | - N_Unchecked_Type_Conversion => - return not Comes_From_Source (Exp) - and then - OK_For_Limited_Init_In_05 - (Typ, Expression (Original_Node (Exp))); + elsif T = Any_Character then + Ambiguous_Character (Low_Bound (N)); - when N_Indexed_Component | - N_Selected_Component | - N_Explicit_Dereference => - return Nkind (Exp) = N_Function_Call; + T := Standard_Character; + end if; - -- A use of 'Input is a function call, hence allowed. Normally the - -- attribute will be changed to a call, but the attribute by itself - -- can occur with -gnatc. + -- The node may be overloaded because some user-defined operators + -- are available, but if a universal interpretation exists it is + -- also the selected one. - when N_Attribute_Reference => - return Attribute_Name (Original_Node (Exp)) = Name_Input; + elsif Universal_Interpretation (N) = Universal_Integer then + T := Standard_Integer; - -- For a case expression, all dependent expressions must be legal + else + T := Any_Type; - when N_Case_Expression => declare - Alt : Node_Id; + Ind : Interp_Index; + It : Interp; begin - Alt := First (Alternatives (Original_Node (Exp))); - while Present (Alt) loop - if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then - return False; + Get_First_Interp (N, Ind, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + + if Found + and then not Covers (It.Typ, T) + and then not Covers (T, It.Typ) + then + Error_Msg_N ("ambiguous bounds in discrete range", N); + exit; + else + T := It.Typ; + Found := True; + end if; end if; - Next (Alt); + Get_Next_Interp (Ind, It); end loop; - return True; - end; - - -- For an if expression, all dependent expressions must be legal + if T = Any_Type then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; - when N_If_Expression => - declare - Then_Expr : constant Node_Id := - Next (First (Expressions (Original_Node (Exp)))); - Else_Expr : constant Node_Id := Next (Then_Expr); - begin - return OK_For_Limited_Init_In_05 (Typ, Then_Expr) - and then - OK_For_Limited_Init_In_05 (Typ, Else_Expr); + elsif T = Universal_Integer then + T := Standard_Integer; + end if; end; + end if; - when others => - return False; - end case; - end OK_For_Limited_Init_In_05; + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; + end if; - ------------------------------------------- - -- Ordinary_Fixed_Point_Type_Declaration -- - ------------------------------------------- + if Nkind (Low_Bound (N)) = N_Attribute_Reference + and then Attribute_Name (Low_Bound (N)) = Name_First + and then Is_Entity_Name (Prefix (Low_Bound (N))) + and then Is_Type (Entity (Prefix (Low_Bound (N)))) + and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) + then + -- The type of the index will be the type of the prefix, as long + -- as the upper bound is 'Last of the same type. - procedure Ordinary_Fixed_Point_Type_Declaration - (T : Entity_Id; - Def : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Def); - Delta_Expr : constant Node_Id := Delta_Expression (Def); - RRS : constant Node_Id := Real_Range_Specification (Def); - Implicit_Base : Entity_Id; - Delta_Val : Ureal; - Small_Val : Ureal; - Low_Val : Ureal; - High_Val : Ureal; + Def_Id := Entity (Prefix (Low_Bound (N))); - begin - Check_Restriction (No_Fixed_Point, Def); + if Nkind (High_Bound (N)) /= N_Attribute_Reference + or else Attribute_Name (High_Bound (N)) /= Name_Last + or else not Is_Entity_Name (Prefix (High_Bound (N))) + or else Entity (Prefix (High_Bound (N))) /= Def_Id + then + Def_Id := Empty; + end if; + end if; - -- Create implicit base type + R := N; + Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); - Implicit_Base := - Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); - Set_Etype (Implicit_Base, Implicit_Base); + elsif Nkind (N) = N_Subtype_Indication then - -- Analyze and process delta expression + -- The index is given by a subtype with a range constraint - Analyze_And_Resolve (Delta_Expr, Any_Real); + T := Base_Type (Entity (Subtype_Mark (N))); - Check_Delta_Expression (Delta_Expr); - Delta_Val := Expr_Value_R (Delta_Expr); + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; + end if; - Set_Delta_Value (Implicit_Base, Delta_Val); + R := Range_Expression (Constraint (N)); - -- Compute default small from given delta, which is the largest power - -- of two that does not exceed the given delta value. + Resolve (R, T); + Process_Range_Expr_In_Decl + (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); - declare - Tmp : Ureal; - Scale : Int; + elsif Nkind (N) = N_Attribute_Reference then - begin - Tmp := Ureal_1; - Scale := 0; + -- Catch beginner's error (use of attribute other than 'Range) - if Delta_Val < Ureal_1 then - while Delta_Val < Tmp loop - Tmp := Tmp / Ureal_2; - Scale := Scale + 1; - end loop; + if Attribute_Name (N) /= Name_Range then + Error_Msg_N ("expect attribute ''Range", N); + Set_Etype (N, Any_Type); + return; + end if; - else - loop - Tmp := Tmp * Ureal_2; - exit when Tmp > Delta_Val; - Scale := Scale - 1; - end loop; + -- If the node denotes the range of a type mark, that is also the + -- resulting type, and we do not need to create an Itype for it. + + if Is_Entity_Name (Prefix (N)) + and then Comes_From_Source (N) + and then Is_Type (Entity (Prefix (N))) + and then Is_Discrete_Type (Entity (Prefix (N))) + then + Def_Id := Entity (Prefix (N)); end if; - Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); - end; + Analyze_And_Resolve (N); + T := Etype (N); + R := N; - Set_Small_Value (Implicit_Base, Small_Val); + -- If none of the above, must be a subtype. We convert this to a + -- range attribute reference because in the case of declared first + -- named subtypes, the types in the range reference can be different + -- from the type of the entity. A range attribute normalizes the + -- reference and obtains the correct types for the bounds. + + -- This transformation is in the nature of an expansion, is only + -- done if expansion is active. In particular, it is not done on + -- formal generic types, because we need to retain the name of the + -- original index for instantiation purposes. + + else + if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then + Error_Msg_N ("invalid subtype mark in discrete range ", N); + Set_Etype (N, Any_Integer); + return; + + else + -- The type mark may be that of an incomplete type. It is only + -- now that we can get the full view, previous analysis does + -- not look specifically for a type mark. + + Set_Entity (N, Get_Full_View (Entity (N))); + Set_Etype (N, Entity (N)); + Def_Id := Entity (N); - -- If no range was given, set a dummy range + if not Is_Discrete_Type (Def_Id) then + Error_Msg_N ("discrete type required for index", N); + Set_Etype (N, Any_Type); + return; + end if; + end if; - if RRS <= Empty_Or_Error then - Low_Val := -Small_Val; - High_Val := Small_Val; + if Expander_Active then + Rewrite (N, + Make_Attribute_Reference (Sloc (N), + Attribute_Name => Name_Range, + Prefix => Relocate_Node (N))); - -- Otherwise analyze and process given range + -- The original was a subtype mark that does not freeze. This + -- means that the rewritten version must not freeze either. - else - declare - Low : constant Node_Id := Low_Bound (RRS); - High : constant Node_Id := High_Bound (RRS); + Set_Must_Not_Freeze (N); + Set_Must_Not_Freeze (Prefix (N)); + Analyze_And_Resolve (N); + T := Etype (N); + R := N; - begin - Analyze_And_Resolve (Low, Any_Real); - Analyze_And_Resolve (High, Any_Real); - Check_Real_Bound (Low); - Check_Real_Bound (High); + -- If expander is inactive, type is legal, nothing else to construct - -- Obtain and set the range + else + return; + end if; + end if; - Low_Val := Expr_Value_R (Low); - High_Val := Expr_Value_R (High); + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; - if Low_Val > High_Val then - Error_Msg_NE ("??fixed point type& has null range", Def, T); - end if; - end; + elsif T = Any_Type then + Set_Etype (N, Any_Type); + return; end if; - -- The range for both the implicit base and the declared first subtype - -- cannot be set yet, so we use the special routine Set_Fixed_Range to - -- set a temporary range in place. Note that the bounds of the base - -- type will be widened to be symmetrical and to fill the available - -- bits when the type is frozen. + -- We will now create the appropriate Itype to describe the range, but + -- first a check. If we originally had a subtype, then we just label + -- the range with this subtype. Not only is there no need to construct + -- a new subtype, but it is wrong to do so for two reasons: - -- We could do this with all discrete types, and probably should, but - -- we absolutely have to do it for fixed-point, since the end-points - -- of the range and the size are determined by the small value, which - -- could be reset before the freeze point. + -- 1. A legality concern, if we have a subtype, it must not freeze, + -- and the Itype would cause freezing incorrectly - Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); - Set_Fixed_Range (T, Loc, Low_Val, High_Val); + -- 2. An efficiency concern, if we created an Itype, it would not be + -- recognized as the same type for the purposes of eliminating + -- checks in some circumstances. - -- Complete definition of first subtype + -- We signal this case by setting the subtype entity in Def_Id - Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Init_Size_Align (T); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Small_Value (T, Small_Val); - Set_Delta_Value (T, Delta_Val); - Set_Is_Constrained (T); + if No (Def_Id) then + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); + Set_Etype (Def_Id, Base_Type (T)); - end Ordinary_Fixed_Point_Type_Declaration; + if Is_Signed_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); - ---------------------------------------- - -- Prepare_Private_Subtype_Completion -- - ---------------------------------------- + elsif Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); - procedure Prepare_Private_Subtype_Completion - (Id : Entity_Id; - Related_Nod : Node_Id) - is - Id_B : constant Entity_Id := Base_Type (Id); - Full_B : Entity_Id := Full_View (Id_B); - Full : Entity_Id; + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; - begin - if Present (Full_B) then + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - -- Get to the underlying full view if necessary + Set_Scalar_Range (Def_Id, R); + Conditional_Delay (Def_Id, T); - if Is_Private_Type (Full_B) - and then Present (Underlying_Full_View (Full_B)) - then - Full_B := Underlying_Full_View (Full_B); + if Nkind (N) = N_Subtype_Indication then + Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); end if; - -- The Base_Type is already completed, we can complete the subtype - -- now. We have to create a new entity with the same name, Thus we - -- can't use Create_Itype. + -- In the subtype indication case, if the immediate parent of the + -- new subtype is non-static, then the subtype we create is non- + -- static, even if its bounds are static. - Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); - Set_Is_Itype (Full); - Set_Associated_Node_For_Itype (Full, Related_Nod); - Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); + if Nkind (N) = N_Subtype_Indication + and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) + then + Set_Is_Non_Static_Subtype (Def_Id); + end if; end if; - -- The parent subtype may be private, but the base might not, in some - -- nested instances. In that case, the subtype does not need to be - -- exchanged. It would still be nice to make private subtypes and their - -- bases consistent at all times ??? + -- Final step is to label the index with this constructed type - if Is_Private_Type (Id_B) then - Append_Elmt (Id, Private_Dependents (Id_B)); - end if; - end Prepare_Private_Subtype_Completion; + Set_Etype (N, Def_Id); + end Make_Index; - --------------------------- - -- Process_Discriminants -- - --------------------------- + ------------------------------ + -- Modular_Type_Declaration -- + ------------------------------ - procedure Process_Discriminants - (N : Node_Id; - Prev : Entity_Id := Empty) - is - Elist : constant Elist_Id := New_Elmt_List; - Id : Node_Id; - Discr : Node_Id; - Discr_Number : Uint; - Discr_Type : Entity_Id; - Default_Present : Boolean := False; - Default_Not_Present : Boolean := False; + procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Mod_Expr : constant Node_Id := Expression (Def); + M_Val : Uint; - begin - -- A composite type other than an array type can have discriminants. - -- On entry, the current scope is the composite type. + procedure Set_Modular_Size (Bits : Int); + -- Sets RM_Size to Bits, and Esize to normal word size above this - -- The discriminants are initially entered into the scope of the type - -- via Enter_Name with the default Ekind of E_Void to prevent premature - -- use, as explained at the end of this procedure. + ---------------------- + -- Set_Modular_Size -- + ---------------------- - Discr := First (Discriminant_Specifications (N)); - while Present (Discr) loop - Enter_Name (Defining_Identifier (Discr)); + procedure Set_Modular_Size (Bits : Int) is + begin + Set_RM_Size (T, UI_From_Int (Bits)); - -- For navigation purposes we add a reference to the discriminant - -- in the entity for the type. If the current declaration is a - -- completion, place references on the partial view. Otherwise the - -- type is the current scope. + if Bits <= 8 then + Init_Esize (T, 8); - if Present (Prev) then + elsif Bits <= 16 then + Init_Esize (T, 16); - -- The references go on the partial view, if present. If the - -- partial view has discriminants, the references have been - -- generated already. + elsif Bits <= 32 then + Init_Esize (T, 32); - if not Has_Discriminants (Prev) then - Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); - end if; else - Generate_Reference - (Current_Scope, Defining_Identifier (Discr), 'd'); + Init_Esize (T, System_Max_Binary_Modulus_Power); end if; - if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then - Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); + if not Non_Binary_Modulus (T) + and then Esize (T) = RM_Size (T) + then + Set_Is_Known_Valid (T); + end if; + end Set_Modular_Size; - -- Ada 2005 (AI-254) + -- Start of processing for Modular_Type_Declaration - if Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - and then Protected_Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - then - Discr_Type := - Replace_Anonymous_Access_To_Protected_Subprogram (Discr); - end if; + begin + -- If the mod expression is (exactly) 2 * literal, where literal is + -- 64 or less,then almost certainly the * was meant to be **. Warn. + + if Warn_On_Suspicious_Modulus_Value + and then Nkind (Mod_Expr) = N_Op_Multiply + and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal + and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 + and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal + and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 + then + Error_Msg_N + ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); + end if; + + -- Proceed with analysis of mod expression + + Analyze_And_Resolve (Mod_Expr, Any_Integer); + Set_Etype (T, T); + Set_Ekind (T, E_Modular_Integer_Type); + Init_Alignment (T); + Set_Is_Constrained (T); + + if not Is_OK_Static_Expression (Mod_Expr) then + Flag_Non_Static_Expr + ("non-static expression used for modular type bound!", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + else + M_Val := Expr_Value (Mod_Expr); + end if; + + if M_Val < 1 then + Error_Msg_N ("modulus value must be positive", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + end if; - else - Find_Type (Discriminant_Type (Discr)); - Discr_Type := Etype (Discriminant_Type (Discr)); + if M_Val > 2 ** Standard_Long_Integer_Size then + Check_Restriction (No_Long_Long_Integers, Mod_Expr); + end if; - if Error_Posted (Discriminant_Type (Discr)) then - Discr_Type := Any_Type; - end if; - end if; + Set_Modulus (T, M_Val); - -- Handling of discriminants that are access types + -- Create bounds for the modular type based on the modulus given in + -- the type declaration and then analyze and resolve those bounds. - if Is_Access_Type (Discr_Type) then + Set_Scalar_Range (T, + Make_Range (Sloc (Mod_Expr), + Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), + High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); - -- Ada 2005 (AI-230): Access discriminant allowed in non- - -- limited record types + -- Properly analyze the literals for the range. We do this manually + -- because we can't go calling Resolve, since we are resolving these + -- bounds with the type, and this type is certainly not complete yet. - if Ada_Version < Ada_2005 then - Check_Access_Discriminant_Requires_Limited - (Discr, Discriminant_Type (Discr)); - end if; + Set_Etype (Low_Bound (Scalar_Range (T)), T); + Set_Etype (High_Bound (Scalar_Range (T)), T); + Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); + Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); - if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then - Error_Msg_N - ("(Ada 83) access discriminant not allowed", Discr); - end if; + -- Loop through powers of two to find number of bits required - -- If not access type, must be a discrete type + for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop - elsif not Is_Discrete_Type (Discr_Type) then - Error_Msg_N - ("discriminants must have a discrete or access type", - Discriminant_Type (Discr)); - end if; + -- Binary case - Set_Etype (Defining_Identifier (Discr), Discr_Type); + if M_Val = 2 ** Bits then + Set_Modular_Size (Bits); + return; - -- If a discriminant specification includes the assignment compound - -- delimiter followed by an expression, the expression is the default - -- expression of the discriminant; the default expression must be of - -- the type of the discriminant. (RM 3.7.1) Since this expression is - -- a default expression, we do the special preanalysis, since this - -- expression does not freeze (see section "Handling of Default and - -- Per-Object Expressions" in spec of package Sem). + -- Non-binary case - if Present (Expression (Discr)) then - Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); + elsif M_Val < 2 ** Bits then + Check_SPARK_05_Restriction ("modulus should be a power of 2", T); + Set_Non_Binary_Modulus (T); - -- Legaity checks + if Bits > System_Max_Nonbinary_Modulus_Power then + Error_Msg_Uint_1 := + UI_From_Int (System_Max_Nonbinary_Modulus_Power); + Error_Msg_F + ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); + Set_Modular_Size (System_Max_Binary_Modulus_Power); + return; - if Nkind (N) = N_Formal_Type_Declaration then - Error_Msg_N - ("discriminant defaults not allowed for formal type", - Expression (Discr)); + else + -- In the non-binary case, set size as per RM 13.3(55) - -- Flag an error for a tagged type with defaulted discriminants, - -- excluding limited tagged types when compiling for Ada 2012 - -- (see AI05-0214). + Set_Modular_Size (Bits); + return; + end if; + end if; - elsif Is_Tagged_Type (Current_Scope) - and then (not Is_Limited_Type (Current_Scope) - or else Ada_Version < Ada_2012) - and then Comes_From_Source (N) - then - -- Note: see similar test in Check_Or_Process_Discriminants, to - -- handle the (illegal) case of the completion of an untagged - -- view with discriminants with defaults by a tagged full view. - -- We skip the check if Discr does not come from source, to - -- account for the case of an untagged derived type providing - -- defaults for a renamed discriminant from a private untagged - -- ancestor with a tagged full view (ACATS B460006). + end loop; - if Ada_Version >= Ada_2012 then - Error_Msg_N - ("discriminants of nonlimited tagged type cannot have" - & " defaults", - Expression (Discr)); - else - Error_Msg_N - ("discriminants of tagged type cannot have defaults", - Expression (Discr)); - end if; + -- If we fall through, then the size exceed System.Max_Binary_Modulus + -- so we just signal an error and set the maximum size. - else - Default_Present := True; - Append_Elmt (Expression (Discr), Elist); + Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); + Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); - -- Tag the defining identifiers for the discriminants with - -- their corresponding default expressions from the tree. + Set_Modular_Size (System_Max_Binary_Modulus_Power); + Init_Alignment (T); - Set_Discriminant_Default_Value - (Defining_Identifier (Discr), Expression (Discr)); - end if; + end Modular_Type_Declaration; - -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag - -- gets set unless we can be sure that no range check is required. + -------------------------- + -- New_Concatenation_Op -- + -------------------------- - if (GNATprove_Mode or not Expander_Active) - and then not - Is_In_Range - (Expression (Discr), Discr_Type, Assume_Valid => True) - then - Set_Do_Range_Check (Expression (Discr)); - end if; + procedure New_Concatenation_Op (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Op : Entity_Id; - -- No default discriminant value given + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; + -- Create abbreviated declaration for the formal of a predefined + -- Operator 'Op' of type 'Typ' - else - Default_Not_Present := True; - end if; + -------------------- + -- Make_Op_Formal -- + -------------------- - -- Ada 2005 (AI-231): Create an Itype that is a duplicate of - -- Discr_Type but with the null-exclusion attribute + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is + Formal : Entity_Id; + begin + Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); + Set_Etype (Formal, Typ); + Set_Mechanism (Formal, Default_Mechanism); + return Formal; + end Make_Op_Formal; - if Ada_Version >= Ada_2005 then + -- Start of processing for New_Concatenation_Op - -- Ada 2005 (AI-231): Static checks + begin + Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); - if Can_Never_Be_Null (Discr_Type) then - Null_Exclusion_Static_Checks (Discr); + Set_Ekind (Op, E_Operator); + Set_Scope (Op, Current_Scope); + Set_Etype (Op, Typ); + Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); + Set_Is_Immediately_Visible (Op); + Set_Is_Intrinsic_Subprogram (Op); + Set_Has_Completion (Op); + Append_Entity (Op, Current_Scope); - elsif Is_Access_Type (Discr_Type) - and then Null_Exclusion_Present (Discr) + Set_Name_Entity_Id (Name_Op_Concat, Op); - -- No need to check itypes because in their case this check - -- was done at their point of creation + Append_Entity (Make_Op_Formal (Typ, Op), Op); + Append_Entity (Make_Op_Formal (Typ, Op), Op); + end New_Concatenation_Op; - and then not Is_Itype (Discr_Type) - then - if Can_Never_Be_Null (Discr_Type) then - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Discr, - Discr_Type); - end if; + ------------------------- + -- OK_For_Limited_Init -- + ------------------------- - Set_Etype (Defining_Identifier (Discr), - Create_Null_Excluding_Itype - (T => Discr_Type, - Related_Nod => Discr)); + -- ???Check all calls of this, and compare the conditions under which it's + -- called. - -- Check for improper null exclusion if the type is otherwise - -- legal for a discriminant. + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + return Is_CPP_Constructor_Call (Exp) + or else (Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L + and then OK_For_Limited_Init_In_05 (Typ, Exp)); + end OK_For_Limited_Init; - elsif Null_Exclusion_Present (Discr) - and then Is_Discrete_Type (Discr_Type) - then - Error_Msg_N - ("null exclusion can only apply to an access type", Discr); - end if; + ------------------------------- + -- OK_For_Limited_Init_In_05 -- + ------------------------------- - -- Ada 2005 (AI-402): access discriminants of nonlimited types - -- can't have defaults. Synchronized types, or types that are - -- explicitly limited are fine, but special tests apply to derived - -- types in generics: in a generic body we have to assume the - -- worst, and therefore defaults are not allowed if the parent is - -- a generic formal private type (see ACATS B370001). + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + -- An object of a limited interface type can be initialized with any + -- expression of a nonlimited descendant type. - if Is_Access_Type (Discr_Type) and then Default_Present then - if Ekind (Discr_Type) /= E_Anonymous_Access_Type - or else Is_Limited_Record (Current_Scope) - or else Is_Concurrent_Type (Current_Scope) - or else Is_Concurrent_Record_Type (Current_Scope) - or else Ekind (Current_Scope) = E_Limited_Private_Type - then - if not Is_Derived_Type (Current_Scope) - or else not Is_Generic_Type (Etype (Current_Scope)) - or else not In_Package_Body (Scope (Etype (Current_Scope))) - or else Limited_Present - (Type_Definition (Parent (Current_Scope))) - then - null; + if Is_Class_Wide_Type (Typ) + and then Is_Limited_Interface (Typ) + and then not Is_Limited_Type (Etype (Exp)) + then + return True; + end if; + + -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in + -- case of limited aggregates (including extension aggregates), and + -- function calls. The function call may have been given in prefixed + -- notation, in which case the original node is an indexed component. + -- If the function is parameterless, the original node was an explicit + -- dereference. The function may also be parameterless, in which case + -- the source node is just an identifier. - else - Error_Msg_N ("access discriminants of nonlimited types", - Expression (Discr)); - Error_Msg_N ("\cannot have defaults", Expression (Discr)); - end if; + case Nkind (Original_Node (Exp)) is + when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => + return True; - elsif Present (Expression (Discr)) then - Error_Msg_N - ("(Ada 2005) access discriminants of nonlimited types", - Expression (Discr)); - Error_Msg_N ("\cannot have defaults", Expression (Discr)); - end if; - end if; - end if; + when N_Identifier => + return Present (Entity (Original_Node (Exp))) + and then Ekind (Entity (Original_Node (Exp))) = E_Function; - -- A discriminant cannot be effectively volatile. This check is only - -- relevant when SPARK_Mode is on as it is not standard Ada legality - -- rule (SPARK RM 7.1.3(6)). + when N_Qualified_Expression => + return + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); - if SPARK_Mode = On - and then Is_Effectively_Volatile (Defining_Identifier (Discr)) - then - Error_Msg_N ("discriminant cannot be volatile", Discr); - end if; + -- Ada 2005 (AI-251): If a class-wide interface object is initialized + -- with a function call, the expander has rewritten the call into an + -- N_Type_Conversion node to force displacement of the pointer to + -- reference the component containing the secondary dispatch table. + -- Otherwise a type conversion is not a legal context. + -- A return statement for a build-in-place function returning a + -- synchronized type also introduces an unchecked conversion. - Next (Discr); - end loop; + when N_Type_Conversion | + N_Unchecked_Type_Conversion => + return not Comes_From_Source (Exp) + and then + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); - -- An element list consisting of the default expressions of the - -- discriminants is constructed in the above loop and used to set - -- the Discriminant_Constraint attribute for the type. If an object - -- is declared of this (record or task) type without any explicit - -- discriminant constraint given, this element list will form the - -- actual parameters for the corresponding initialization procedure - -- for the type. + when N_Indexed_Component | + N_Selected_Component | + N_Explicit_Dereference => + return Nkind (Exp) = N_Function_Call; - Set_Discriminant_Constraint (Current_Scope, Elist); - Set_Stored_Constraint (Current_Scope, No_Elist); + -- A use of 'Input is a function call, hence allowed. Normally the + -- attribute will be changed to a call, but the attribute by itself + -- can occur with -gnatc. - -- Default expressions must be provided either for all or for none - -- of the discriminants of a discriminant part. (RM 3.7.1) + when N_Attribute_Reference => + return Attribute_Name (Original_Node (Exp)) = Name_Input; - if Default_Present and then Default_Not_Present then - Error_Msg_N - ("incomplete specification of defaults for discriminants", N); - end if; + -- For a case expression, all dependent expressions must be legal - -- The use of the name of a discriminant is not allowed in default - -- expressions of a discriminant part if the specification of the - -- discriminant is itself given in the discriminant part. (RM 3.7.1) + when N_Case_Expression => + declare + Alt : Node_Id; - -- To detect this, the discriminant names are entered initially with an - -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any - -- attempt to use a void entity (for example in an expression that is - -- type-checked) produces the error message: premature usage. Now after - -- completing the semantic analysis of the discriminant part, we can set - -- the Ekind of all the discriminants appropriately. + begin + Alt := First (Alternatives (Original_Node (Exp))); + while Present (Alt) loop + if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then + return False; + end if; - Discr := First (Discriminant_Specifications (N)); - Discr_Number := Uint_1; - while Present (Discr) loop - Id := Defining_Identifier (Discr); - Set_Ekind (Id, E_Discriminant); - Init_Component_Location (Id); - Init_Esize (Id); - Set_Discriminant_Number (Id, Discr_Number); + Next (Alt); + end loop; - -- Make sure this is always set, even in illegal programs + return True; + end; - Set_Corresponding_Discriminant (Id, Empty); + -- For an if expression, all dependent expressions must be legal - -- Initialize the Original_Record_Component to the entity itself. - -- Inherit_Components will propagate the right value to - -- discriminants in derived record types. + when N_If_Expression => + declare + Then_Expr : constant Node_Id := + Next (First (Expressions (Original_Node (Exp)))); + Else_Expr : constant Node_Id := Next (Then_Expr); + begin + return OK_For_Limited_Init_In_05 (Typ, Then_Expr) + and then + OK_For_Limited_Init_In_05 (Typ, Else_Expr); + end; - Set_Original_Record_Component (Id, Id); + when others => + return False; + end case; + end OK_For_Limited_Init_In_05; - -- Create the discriminal for the discriminant + ------------------------------------------- + -- Ordinary_Fixed_Point_Type_Declaration -- + ------------------------------------------- - Build_Discriminal (Id); + procedure Ordinary_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + RRS : constant Node_Id := Real_Range_Specification (Def); + Implicit_Base : Entity_Id; + Delta_Val : Ureal; + Small_Val : Ureal; + Low_Val : Ureal; + High_Val : Ureal; - Next (Discr); - Discr_Number := Discr_Number + 1; - end loop; + begin + Check_Restriction (No_Fixed_Point, Def); - Set_Has_Discriminants (Current_Scope); - end Process_Discriminants; + -- Create implicit base type - ----------------------- - -- Process_Full_View -- - ----------------------- + Implicit_Base := + Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); - 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; + -- Analyze and process delta expression - procedure Collect_Implemented_Interfaces - (Typ : Entity_Id; - Ifaces : Elist_Id); - -- Ada 2005: Gather all the interfaces that Typ directly or - -- inherently implements. Duplicate entries are not added to - -- the list Ifaces. + Analyze_And_Resolve (Delta_Expr, Any_Real); - ------------------------------------ - -- Collect_Implemented_Interfaces -- - ------------------------------------ + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); - procedure Collect_Implemented_Interfaces - (Typ : Entity_Id; - Ifaces : Elist_Id) - is - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; + Set_Delta_Value (Implicit_Base, Delta_Val); - begin - -- Abstract interfaces are only associated with tagged record types + -- Compute default small from given delta, which is the largest power + -- of two that does not exceed the given delta value. - if not Is_Tagged_Type (Typ) - or else not Is_Record_Type (Typ) - then - return; - end if; + declare + Tmp : Ureal; + Scale : Int; - -- Recursively climb to the ancestors + begin + Tmp := Ureal_1; + Scale := 0; - if Etype (Typ) /= Typ + if Delta_Val < Ureal_1 then + while Delta_Val < Tmp loop + Tmp := Tmp / Ureal_2; + Scale := Scale + 1; + end loop; - -- Protect the frontend against wrong cyclic declarations like: + else + loop + Tmp := Tmp * Ureal_2; + exit when Tmp > Delta_Val; + Scale := Scale - 1; + end loop; + end if; - -- type B is new A with private; - -- type C is new A with private; - -- private - -- type B is new C with null record; - -- type C is new B with null record; + Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); + end; - and then Etype (Typ) /= Priv_T - and then Etype (Typ) /= Full_T - then - -- Keep separate the management of private type declarations + Set_Small_Value (Implicit_Base, Small_Val); - if Ekind (Typ) = E_Record_Type_With_Private then + -- If no range was given, set a dummy range - -- Handle the following illegal usage: - -- type Private_Type is tagged private; - -- private - -- type Private_Type is new Type_Implementing_Iface; + if RRS <= Empty_Or_Error then + Low_Val := -Small_Val; + High_Val := Small_Val; - if Present (Full_View (Typ)) - and then Etype (Typ) /= Full_View (Typ) - then - if Is_Interface (Etype (Typ)) then - Append_Unique_Elmt (Etype (Typ), Ifaces); - end if; + -- Otherwise analyze and process given range - Collect_Implemented_Interfaces (Etype (Typ), Ifaces); - end if; + else + declare + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); - -- Non-private types + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); - else - if Is_Interface (Etype (Typ)) then - Append_Unique_Elmt (Etype (Typ), Ifaces); - end if; + -- Obtain and set the range + + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); - Collect_Implemented_Interfaces (Etype (Typ), Ifaces); + if Low_Val > High_Val then + Error_Msg_NE ("??fixed point type& has null range", Def, T); end if; - end if; + end; + end if; - -- Handle entities in the list of abstract interfaces + -- The range for both the implicit base and the declared first subtype + -- cannot be set yet, so we use the special routine Set_Fixed_Range to + -- set a temporary range in place. Note that the bounds of the base + -- type will be widened to be symmetrical and to fill the available + -- bits when the type is frozen. - if Present (Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Interfaces (Typ)); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + -- We could do this with all discrete types, and probably should, but + -- we absolutely have to do it for fixed-point, since the end-points + -- of the range and the size are determined by the small value, which + -- could be reset before the freeze point. - pragma Assert (Is_Interface (Iface)); + Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); + Set_Fixed_Range (T, Loc, Low_Val, High_Val); - if not Contain_Interface (Iface, Ifaces) then - Append_Elmt (Iface, Ifaces); - Collect_Implemented_Interfaces (Iface, Ifaces); - end if; + -- Complete definition of first subtype - Next_Elmt (Iface_Elmt); - end loop; - end if; - end Collect_Implemented_Interfaces; + Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Init_Size_Align (T); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Small_Value (T, Small_Val); + Set_Delta_Value (T, Delta_Val); + Set_Is_Constrained (T); + end Ordinary_Fixed_Point_Type_Declaration; - -- Start of processing for Process_Full_View + ---------------------------------- + -- Preanalyze_Assert_Expression -- + ---------------------------------- + procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is begin - -- First some sanity checks that must be done after semantic - -- decoration of the full view and thus cannot be placed with other - -- similar checks in Find_Type_Name + In_Assertion_Expr := In_Assertion_Expr + 1; + Preanalyze_Spec_Expression (N, T); + In_Assertion_Expr := In_Assertion_Expr - 1; + end Preanalyze_Assert_Expression; - if not Is_Limited_Type (Priv_T) - and then (Is_Limited_Type (Full_T) - or else Is_Limited_Composite (Full_T)) - then - if In_Instance then - null; - else - Error_Msg_N - ("completion of nonlimited type cannot be limited", Full_T); - Explain_Limited_Type (Full_T, Full_T); - end if; + ----------------------------------- + -- Preanalyze_Default_Expression -- + ----------------------------------- - elsif Is_Abstract_Type (Full_T) - and then not Is_Abstract_Type (Priv_T) - then - Error_Msg_N - ("completion of nonabstract type cannot be abstract", Full_T); + 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; - elsif Is_Tagged_Type (Priv_T) - and then Is_Limited_Type (Priv_T) - and then not Is_Limited_Type (Full_T) - then - -- If pragma CPP_Class was applied to the private declaration - -- propagate the limitedness to the full-view + -------------------------------- + -- Preanalyze_Spec_Expression -- + -------------------------------- - if Is_CPP_Class (Priv_T) then - Set_Is_Limited_Record (Full_T); + 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; - -- GNAT allow its own definition of Limited_Controlled to disobey - -- this rule in order in ease the implementation. This test is safe - -- because Root_Controlled is defined in a child of System that - -- normal programs are not supposed to use. + ---------------------------------------- + -- Prepare_Private_Subtype_Completion -- + ---------------------------------------- - elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then - Set_Is_Limited_Composite (Full_T); - else - Error_Msg_N - ("completion of limited tagged type must be limited", Full_T); + procedure Prepare_Private_Subtype_Completion + (Id : Entity_Id; + Related_Nod : Node_Id) + is + Id_B : constant Entity_Id := Base_Type (Id); + Full_B : Entity_Id := Full_View (Id_B); + Full : Entity_Id; + + begin + if Present (Full_B) then + + -- Get to the underlying full view if necessary + + if Is_Private_Type (Full_B) + and then Present (Underlying_Full_View (Full_B)) + then + Full_B := Underlying_Full_View (Full_B); end if; - elsif Is_Generic_Type (Priv_T) then - Error_Msg_N ("generic type cannot have a completion", Full_T); + -- The Base_Type is already completed, we can complete the subtype + -- now. We have to create a new entity with the same name, Thus we + -- can't use Create_Itype. + + Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); + Set_Is_Itype (Full); + Set_Associated_Node_For_Itype (Full, Related_Nod); + Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); end if; - -- Check that ancestor interfaces of private and full views are - -- consistent. We omit this check for synchronized types because - -- they are performed on the corresponding record type when frozen. + -- The parent subtype may be private, but the base might not, in some + -- nested instances. In that case, the subtype does not need to be + -- exchanged. It would still be nice to make private subtypes and their + -- bases consistent at all times ??? - if Ada_Version >= Ada_2005 - and then Is_Tagged_Type (Priv_T) - and then Is_Tagged_Type (Full_T) - and then not Is_Concurrent_Type (Full_T) - then - declare - Iface : Entity_Id; - Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; - Full_T_Ifaces : constant Elist_Id := New_Elmt_List; + if Is_Private_Type (Id_B) then + Append_Elmt (Id, Private_Dependents (Id_B)); + end if; + end Prepare_Private_Subtype_Completion; - begin - Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); - Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); + --------------------------- + -- Process_Discriminants -- + --------------------------- - -- 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)). + procedure Process_Discriminants + (N : Node_Id; + Prev : Entity_Id := Empty) + is + Elist : constant Elist_Id := New_Elmt_List; + Id : Node_Id; + Discr : Node_Id; + Discr_Number : Uint; + Discr_Type : Entity_Id; + Default_Present : Boolean := False; + Default_Not_Present : Boolean := False; - Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + begin + -- A composite type other than an array type can have discriminants. + -- On entry, the current scope is the composite type. - if Present (Iface) then - Error_Msg_NE - ("interface in partial view& not implemented by full type " - & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); - end if; + -- The discriminants are initially entered into the scope of the type + -- via Enter_Name with the default Ekind of E_Void to prevent premature + -- use, as explained at the end of this procedure. - Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + Discr := First (Discriminant_Specifications (N)); + while Present (Discr) loop + Enter_Name (Defining_Identifier (Discr)); - if Present (Iface) then - Error_Msg_NE - ("interface & not implemented by partial view " - & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); - end if; - end; - end if; + -- For navigation purposes we add a reference to the discriminant + -- in the entity for the type. If the current declaration is a + -- completion, place references on the partial view. Otherwise the + -- type is the current scope. - if Is_Tagged_Type (Priv_T) - and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then Is_Derived_Type (Full_T) - then - Priv_Parent := Etype (Priv_T); + if Present (Prev) then - -- The full view of a private extension may have been transformed - -- into an unconstrained derived type declaration and a subtype - -- declaration (see build_derived_record_type for details). + -- The references go on the partial view, if present. If the + -- partial view has discriminants, the references have been + -- generated already. - if Nkind (N) = N_Subtype_Declaration then - Full_Indic := Subtype_Indication (N); - Full_Parent := Etype (Base_Type (Full_T)); + if not Has_Discriminants (Prev) then + Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); + end if; else - Full_Indic := Subtype_Indication (Type_Definition (N)); - Full_Parent := Etype (Full_T); + Generate_Reference + (Current_Scope, Defining_Identifier (Discr), 'd'); end if; - -- Check that the parent type of the full type is a descendant of - -- the ancestor subtype given in the private extension. If either - -- entity has an Etype equal to Any_Type then we had some previous - -- error situation [7.3(8)]. + if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then + Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); - if Priv_Parent = Any_Type or else Full_Parent = Any_Type then - return; + -- Ada 2005 (AI-254) - -- Ada 2005 (AI-251): Interfaces in the full type can be given in - -- any order. Therefore we don't have to check that its parent must - -- be a descendant of the parent of the private type declaration. + if Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + and then Protected_Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + then + Discr_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + end if; - elsif Is_Interface (Priv_Parent) - and then Is_Interface (Full_Parent) - then - null; + else + Find_Type (Discriminant_Type (Discr)); + Discr_Type := Etype (Discriminant_Type (Discr)); - -- 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 are performed by Build_Derived_Record_Type. + if Error_Posted (Discriminant_Type (Discr)) then + Discr_Type := Any_Type; + end if; + end if; - 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); + -- Handling of discriminants that are access types - -- First check a formal restriction, and then proceed with checking - -- Ada rules. Since the formal restriction is not a serious error, we - -- don't prevent further error detection for this check, hence the - -- ELSE. + if Is_Access_Type (Discr_Type) then - else + -- Ada 2005 (AI-230): Access discriminant allowed in non- + -- limited record types - -- In formal mode, when completing a private extension the type - -- named in the private part must be exactly the same as that - -- named in the visible part. + if Ada_Version < Ada_2005 then + Check_Access_Discriminant_Requires_Limited + (Discr, Discriminant_Type (Discr)); + end if; - if Priv_Parent /= Full_Parent then - Error_Msg_Name_1 := Chars (Priv_Parent); - Check_SPARK_05_Restriction ("% expected", Full_Indic); + if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then + Error_Msg_N + ("(Ada 83) access discriminant not allowed", Discr); end if; - -- Check the rules of 7.3(10): if the private extension inherits - -- known discriminants, then the full type must also inherit those - -- discriminants from the same (ancestor) type, and the parent - -- subtype of the full type must be constrained if and only if - -- the ancestor subtype of the private extension is constrained. + -- If not access type, must be a discrete type - if No (Discriminant_Specifications (Parent (Priv_T))) - and then not Has_Unknown_Discriminants (Priv_T) - and then Has_Discriminants (Base_Type (Priv_Parent)) - then - declare - Priv_Indic : constant Node_Id := - Subtype_Indication (Parent (Priv_T)); + elsif not Is_Discrete_Type (Discr_Type) then + Error_Msg_N + ("discriminants must have a discrete or access type", + Discriminant_Type (Discr)); + end if; - Priv_Constr : constant Boolean := - Is_Constrained (Priv_Parent) - or else - Nkind (Priv_Indic) = N_Subtype_Indication - or else - Is_Constrained (Entity (Priv_Indic)); + Set_Etype (Defining_Identifier (Discr), Discr_Type); - Full_Constr : constant Boolean := - Is_Constrained (Full_Parent) - or else - Nkind (Full_Indic) = N_Subtype_Indication - or else - Is_Constrained (Entity (Full_Indic)); + -- If a discriminant specification includes the assignment compound + -- delimiter followed by an expression, the expression is the default + -- expression of the discriminant; the default expression must be of + -- the type of the discriminant. (RM 3.7.1) Since this expression is + -- a default expression, we do the special preanalysis, since this + -- expression does not freeze (see section "Handling of Default and + -- Per-Object Expressions" in spec of package Sem). - Priv_Discr : Entity_Id; - Full_Discr : Entity_Id; + if Present (Expression (Discr)) then + Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); - begin - Priv_Discr := First_Discriminant (Priv_Parent); - Full_Discr := First_Discriminant (Full_Parent); - while Present (Priv_Discr) and then Present (Full_Discr) loop - if Original_Record_Component (Priv_Discr) = - Original_Record_Component (Full_Discr) - or else - Corresponding_Discriminant (Priv_Discr) = - Corresponding_Discriminant (Full_Discr) - then - null; - else - exit; - end if; + -- Legaity checks - Next_Discriminant (Priv_Discr); - Next_Discriminant (Full_Discr); - end loop; + if Nkind (N) = N_Formal_Type_Declaration then + Error_Msg_N + ("discriminant defaults not allowed for formal type", + Expression (Discr)); - if Present (Priv_Discr) or else Present (Full_Discr) then - Error_Msg_N - ("full view must inherit discriminants of the parent" - & " type used in the private extension", Full_Indic); + -- Flag an error for a tagged type with defaulted discriminants, + -- excluding limited tagged types when compiling for Ada 2012 + -- (see AI05-0214). - elsif Priv_Constr and then not Full_Constr then - Error_Msg_N - ("parent subtype of full type must be constrained", - Full_Indic); + elsif Is_Tagged_Type (Current_Scope) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then Comes_From_Source (N) + then + -- Note: see similar test in Check_Or_Process_Discriminants, to + -- handle the (illegal) case of the completion of an untagged + -- view with discriminants with defaults by a tagged full view. + -- We skip the check if Discr does not come from source, to + -- account for the case of an untagged derived type providing + -- defaults for a renamed discriminant from a private untagged + -- ancestor with a tagged full view (ACATS B460006). - elsif Full_Constr and then not Priv_Constr then - Error_Msg_N - ("parent subtype of full type must be unconstrained", - Full_Indic); - end if; - end; + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have" + & " defaults", + Expression (Discr)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (Discr)); + end if; - -- Check the rules of 7.3(12): if a partial view has neither - -- known or unknown discriminants, then the full type - -- declaration shall define a definite subtype. + else + Default_Present := True; + Append_Elmt (Expression (Discr), Elist); - elsif not Has_Unknown_Discriminants (Priv_T) - and then not Has_Discriminants (Priv_T) - and then not Is_Constrained (Full_T) + -- Tag the defining identifiers for the discriminants with + -- their corresponding default expressions from the tree. + + Set_Discriminant_Default_Value + (Defining_Identifier (Discr), Expression (Discr)); + end if; + + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag + -- gets set unless we can be sure that no range check is required. + + if (GNATprove_Mode or not Expander_Active) + and then not + Is_In_Range + (Expression (Discr), Discr_Type, Assume_Valid => True) then - Error_Msg_N - ("full view must define a constrained type if partial view" - & " has no discriminants", Full_T); + Set_Do_Range_Check (Expression (Discr)); end if; - -- ??????? Do we implement the following properly ????? - -- If the ancestor subtype of a private extension has constrained - -- discriminants, then the parent subtype of the full view shall - -- impose a statically matching constraint on those discriminants - -- [7.3(13)]. + -- No default discriminant value given + + else + Default_Not_Present := True; end if; - else - -- For untagged types, verify that a type without discriminants is - -- not completed with an unconstrained type. A separate error message - -- is produced if the full type has defaulted discriminants. + -- Ada 2005 (AI-231): Create an Itype that is a duplicate of + -- Discr_Type but with the null-exclusion attribute - if not Is_Indefinite_Subtype (Priv_T) - and then Is_Indefinite_Subtype (Full_T) - then - Error_Msg_Sloc := Sloc (Parent (Priv_T)); - Error_Msg_NE - ("full view of& not compatible with declaration#", - Full_T, Priv_T); + if Ada_Version >= Ada_2005 then - if not Is_Tagged_Type (Full_T) then - Error_Msg_N - ("\one is constrained, the other unconstrained", Full_T); - end if; - end if; - end if; + -- Ada 2005 (AI-231): Static checks - -- AI-419: verify that the use of "limited" is consistent + if Can_Never_Be_Null (Discr_Type) then + Null_Exclusion_Static_Checks (Discr); - declare - Orig_Decl : constant Node_Id := Original_Node (N); + elsif Is_Access_Type (Discr_Type) + and then Null_Exclusion_Present (Discr) - begin - if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then not Limited_Present (Parent (Priv_T)) - and then not Synchronized_Present (Parent (Priv_T)) - and then Nkind (Orig_Decl) = N_Full_Type_Declaration - and then Nkind - (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition - and then Limited_Present (Type_Definition (Orig_Decl)) - then - Error_Msg_N - ("full view of non-limited extension cannot be limited", N); - end if; - end; + -- No need to check itypes because in their case this check + -- was done at their point of creation - -- Ada 2005 (AI-443): A synchronized private extension must be - -- completed by a task or protected type. + and then not Is_Itype (Discr_Type) + then + if Can_Never_Be_Null (Discr_Type) then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Discr, + Discr_Type); + end if; - if Ada_Version >= Ada_2005 - and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then Synchronized_Present (Parent (Priv_T)) - and then not Is_Concurrent_Type (Full_T) - then - Error_Msg_N ("full view of synchronized extension must " & - "be synchronized type", N); - end if; + Set_Etype (Defining_Identifier (Discr), + Create_Null_Excluding_Itype + (T => Discr_Type, + Related_Nod => Discr)); - -- Ada 2005 AI-363: if the full view has discriminants with - -- defaults, it is illegal to declare constrained access subtypes - -- whose designated type is the current type. This allows objects - -- of the type that are declared in the heap to be unconstrained. + -- Check for improper null exclusion if the type is otherwise + -- legal for a discriminant. - if not Has_Unknown_Discriminants (Priv_T) - and then not Has_Discriminants (Priv_T) - and then Has_Discriminants (Full_T) - and then - Present (Discriminant_Default_Value (First_Discriminant (Full_T))) - then - Set_Has_Constrained_Partial_View (Full_T); - Set_Has_Constrained_Partial_View (Priv_T); - end if; + elsif Null_Exclusion_Present (Discr) + and then Is_Discrete_Type (Discr_Type) + then + Error_Msg_N + ("null exclusion can only apply to an access type", Discr); + end if; - -- Create a full declaration for all its subtypes recorded in - -- Private_Dependents and swap them similarly to the base type. These - -- are subtypes that have been define before the full declaration of - -- the private type. We also swap the entry in Private_Dependents list - -- so we can properly restore the private view on exit from the scope. + -- Ada 2005 (AI-402): access discriminants of nonlimited types + -- can't have defaults. Synchronized types, or types that are + -- explicitly limited are fine, but special tests apply to derived + -- types in generics: in a generic body we have to assume the + -- worst, and therefore defaults are not allowed if the parent is + -- a generic formal private type (see ACATS B370001). - declare - Priv_Elmt : Elmt_Id; - Priv_Scop : Entity_Id; - Priv : Entity_Id; - Full : Entity_Id; + if Is_Access_Type (Discr_Type) and then Default_Present then + if Ekind (Discr_Type) /= E_Anonymous_Access_Type + or else Is_Limited_Record (Current_Scope) + or else Is_Concurrent_Type (Current_Scope) + or else Is_Concurrent_Record_Type (Current_Scope) + or else Ekind (Current_Scope) = E_Limited_Private_Type + then + if not Is_Derived_Type (Current_Scope) + or else not Is_Generic_Type (Etype (Current_Scope)) + or else not In_Package_Body (Scope (Etype (Current_Scope))) + or else Limited_Present + (Type_Definition (Parent (Current_Scope))) + then + null; - begin - Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); - while Present (Priv_Elmt) loop - Priv := Node (Priv_Elmt); - Priv_Scop := Scope (Priv); + else + Error_Msg_N ("access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; - if Ekind_In (Priv, E_Private_Subtype, - E_Limited_Private_Subtype, - E_Record_Subtype_With_Private) - then - Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); - Set_Is_Itype (Full); - Set_Parent (Full, Parent (Priv)); - Set_Associated_Node_For_Itype (Full, N); + elsif Present (Expression (Discr)) then + Error_Msg_N + ("(Ada 2005) access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; + end if; + end if; - -- Now we need to complete the private subtype, but since the - -- base type has already been swapped, we must also swap the - -- subtypes (and thus, reverse the arguments in the call to - -- Complete_Private_Subtype). Also note that we may need to - -- re-establish the scope of the private subtype. + -- A discriminant cannot be effectively volatile. This check is only + -- relevant when SPARK_Mode is on as it is not standard Ada legality + -- rule (SPARK RM 7.1.3(6)). - Copy_And_Swap (Priv, Full); + if SPARK_Mode = On + and then Is_Effectively_Volatile (Defining_Identifier (Discr)) + then + Error_Msg_N ("discriminant cannot be volatile", Discr); + end if; - if not In_Open_Scopes (Priv_Scop) then - Push_Scope (Priv_Scop); + Next (Discr); + end loop; - else - -- Reset Priv_Scop to Empty to indicate no scope was pushed + -- An element list consisting of the default expressions of the + -- discriminants is constructed in the above loop and used to set + -- the Discriminant_Constraint attribute for the type. If an object + -- is declared of this (record or task) type without any explicit + -- discriminant constraint given, this element list will form the + -- actual parameters for the corresponding initialization procedure + -- for the type. - Priv_Scop := Empty; - end if; + Set_Discriminant_Constraint (Current_Scope, Elist); + Set_Stored_Constraint (Current_Scope, No_Elist); - Complete_Private_Subtype (Full, Priv, Full_T, N); + -- Default expressions must be provided either for all or for none + -- of the discriminants of a discriminant part. (RM 3.7.1) - if Present (Priv_Scop) then - Pop_Scope; - end if; + if Default_Present and then Default_Not_Present then + Error_Msg_N + ("incomplete specification of defaults for discriminants", N); + end if; - Replace_Elmt (Priv_Elmt, Full); - end if; + -- The use of the name of a discriminant is not allowed in default + -- expressions of a discriminant part if the specification of the + -- discriminant is itself given in the discriminant part. (RM 3.7.1) - Next_Elmt (Priv_Elmt); - end loop; - end; + -- To detect this, the discriminant names are entered initially with an + -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any + -- attempt to use a void entity (for example in an expression that is + -- type-checked) produces the error message: premature usage. Now after + -- completing the semantic analysis of the discriminant part, we can set + -- the Ekind of all the discriminants appropriately. - -- If the private view was tagged, copy the new primitive operations - -- from the private view to the full view. + Discr := First (Discriminant_Specifications (N)); + Discr_Number := Uint_1; + while Present (Discr) loop + Id := Defining_Identifier (Discr); + Set_Ekind (Id, E_Discriminant); + Init_Component_Location (Id); + Init_Esize (Id); + Set_Discriminant_Number (Id, Discr_Number); - if Is_Tagged_Type (Full_T) then - declare - Disp_Typ : Entity_Id; - Full_List : Elist_Id; - Prim : Entity_Id; - Prim_Elmt : Elmt_Id; - Priv_List : Elist_Id; + -- Make sure this is always set, even in illegal programs - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean; - -- Determine whether list L contains element E + Set_Corresponding_Discriminant (Id, Empty); - -------------- - -- Contains -- - -------------- + -- Initialize the Original_Record_Component to the entity itself. + -- Inherit_Components will propagate the right value to + -- discriminants in derived record types. - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean - is - List_Elmt : Elmt_Id; + Set_Original_Record_Component (Id, Id); - begin - List_Elmt := First_Elmt (L); - while Present (List_Elmt) loop - if Node (List_Elmt) = E then - return True; - end if; + -- Create the discriminal for the discriminant - Next_Elmt (List_Elmt); - end loop; + Build_Discriminal (Id); - return False; - end Contains; + Next (Discr); + Discr_Number := Discr_Number + 1; + end loop; - -- Start of processing + Set_Has_Discriminants (Current_Scope); + end Process_Discriminants; - begin - if Is_Tagged_Type (Priv_T) then - Priv_List := Primitive_Operations (Priv_T); - Prim_Elmt := First_Elmt (Priv_List); + ----------------------- + -- Process_Full_View -- + ----------------------- - -- In the case of a concurrent type completing a private tagged - -- type, primitives may have been declared in between the two - -- views. These subprograms need to be wrapped the same way - -- entries and protected procedures are handled because they - -- cannot be directly shared by the two views. + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id); + -- Ada 2005: Gather all the interfaces that Typ directly or + -- inherently implements. Duplicate entries are not added to + -- the list Ifaces. - if Is_Concurrent_Type (Full_T) then - declare - Conc_Typ : constant Entity_Id := - Corresponding_Record_Type (Full_T); - Curr_Nod : Node_Id := Parent (Conc_Typ); - Wrap_Spec : Node_Id; + ------------------------------------ + -- Collect_Implemented_Interfaces -- + ------------------------------------ - begin - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id) + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; - if Comes_From_Source (Prim) - and then not Is_Abstract_Subprogram (Prim) - then - Wrap_Spec := - Make_Subprogram_Declaration (Sloc (Prim), - Specification => - Build_Wrapper_Spec - (Subp_Id => Prim, - Obj_Typ => Conc_Typ, - Formals => - Parameter_Specifications ( - Parent (Prim)))); + begin + -- Abstract interfaces are only associated with tagged record types - Insert_After (Curr_Nod, Wrap_Spec); - Curr_Nod := Wrap_Spec; + if not Is_Tagged_Type (Typ) + or else not Is_Record_Type (Typ) + then + return; + end if; - Analyze (Wrap_Spec); - end if; + -- Recursively climb to the ancestors - Next_Elmt (Prim_Elmt); - end loop; + if Etype (Typ) /= Typ - return; - end; + -- Protect the frontend against wrong cyclic declarations like: - -- For non-concurrent types, transfer explicit primitives, but - -- omit those inherited from the parent of the private view - -- since they will be re-inherited later on. + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; - else - Full_List := Primitive_Operations (Full_T); + and then Etype (Typ) /= Priv_T + and then Etype (Typ) /= Full_T + then + -- Keep separate the management of private type declarations - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); + if Ekind (Typ) = E_Record_Type_With_Private then - if Comes_From_Source (Prim) - and then not Contains (Prim, Full_List) - then - Append_Elmt (Prim, Full_List); - end if; + -- Handle the following illegal usage: + -- type Private_Type is tagged private; + -- private + -- type Private_Type is new Type_Implementing_Iface; - Next_Elmt (Prim_Elmt); - end loop; + if Present (Full_View (Typ)) + and then Etype (Typ) /= Full_View (Typ) + then + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); + end if; + + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); end if; - -- Untagged private view + -- Non-private types else - Full_List := Primitive_Operations (Full_T); + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); + end if; - -- In this case the partial view is untagged, so here we locate - -- all of the earlier primitives that need to be treated as - -- dispatching (those that appear between the two views). Note - -- that these additional operations must all be new operations - -- (any earlier operations that override inherited operations - -- of the full view will already have been inserted in the - -- primitives list, marked by Check_Operation_From_Private_View - -- as dispatching. Note that implicit "/=" operators are - -- excluded from being added to the primitives list since they - -- shouldn't be treated as dispatching (tagged "/=" is handled - -- specially). + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); + end if; + end if; - Prim := Next_Entity (Full_T); - while Present (Prim) and then Prim /= Priv_T loop - if Ekind_In (Prim, E_Procedure, E_Function) then - Disp_Typ := Find_Dispatching_Type (Prim); + -- Handle entities in the list of abstract interfaces - if Disp_Typ = Full_T - and then (Chars (Prim) /= Name_Op_Ne - or else Comes_From_Source (Prim)) - then - Check_Controlling_Formals (Full_T, Prim); + if Present (Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Typ)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - if not Is_Dispatching_Operation (Prim) then - Append_Elmt (Prim, Full_List); - Set_Is_Dispatching_Operation (Prim, True); - Set_DT_Position (Prim, No_Uint); - end if; + pragma Assert (Is_Interface (Iface)); - elsif Is_Dispatching_Operation (Prim) - and then Disp_Typ /= Full_T - then + if not Contain_Interface (Iface, Ifaces) then + Append_Elmt (Iface, Ifaces); + Collect_Implemented_Interfaces (Iface, Ifaces); + end if; - -- Verify that it is not otherwise controlled by a - -- formal or a return value of type T. + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Collect_Implemented_Interfaces; - Check_Controlling_Formals (Disp_Typ, Prim); - end if; - end if; + -- Local variables - Next_Entity (Prim); - end loop; - end if; + Full_Indic : Node_Id; + Full_Parent : Entity_Id; + Priv_Parent : Entity_Id; - -- For the tagged case, the two views can share the same primitive - -- operations list and the same class-wide type. Update attributes - -- of the class-wide type which depend on the full declaration. + -- Start of processing for Process_Full_View - if Is_Tagged_Type (Priv_T) then - Set_Direct_Primitive_Operations (Priv_T, Full_List); - Set_Class_Wide_Type - (Base_Type (Full_T), Class_Wide_Type (Priv_T)); + begin + -- First some sanity checks that must be done after semantic + -- decoration of the full view and thus cannot be placed with other + -- similar checks in Find_Type_Name - Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); - Set_Has_Protected - (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); - end if; - end; - end if; + if not Is_Limited_Type (Priv_T) + and then (Is_Limited_Type (Full_T) + or else Is_Limited_Composite (Full_T)) + then + if In_Instance then + null; + else + Error_Msg_N + ("completion of nonlimited type cannot be limited", Full_T); + Explain_Limited_Type (Full_T, Full_T); + end if; - -- Ada 2005 AI 161: Check preelaborable initialization consistency + elsif Is_Abstract_Type (Full_T) + and then not Is_Abstract_Type (Priv_T) + then + Error_Msg_N + ("completion of nonabstract type cannot be abstract", Full_T); - if Known_To_Have_Preelab_Init (Priv_T) then + elsif Is_Tagged_Type (Priv_T) + and then Is_Limited_Type (Priv_T) + and then not Is_Limited_Type (Full_T) + then + -- If pragma CPP_Class was applied to the private declaration + -- propagate the limitedness to the full-view - -- Case where there is a pragma Preelaborable_Initialization. We - -- always allow this in predefined units, which is cheating a bit, - -- but it means we don't have to struggle to meet the requirements in - -- the RM for having Preelaborable Initialization. Otherwise we - -- require that the type meets the RM rules. But we can't check that - -- yet, because of the rule about overriding Initialize, so we simply - -- set a flag that will be checked at freeze time. + if Is_CPP_Class (Priv_T) then + Set_Is_Limited_Record (Full_T); - if not In_Predefined_Unit (Full_T) then - Set_Must_Have_Preelab_Init (Full_T); + -- GNAT allow its own definition of Limited_Controlled to disobey + -- this rule in order in ease the implementation. This test is safe + -- because Root_Controlled is defined in a child of System that + -- normal programs are not supposed to use. + + elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then + Set_Is_Limited_Composite (Full_T); + else + Error_Msg_N + ("completion of limited tagged type must be limited", Full_T); end if; + + elsif Is_Generic_Type (Priv_T) then + Error_Msg_N ("generic type cannot have a completion", Full_T); end if; - -- If pragma CPP_Class was applied to the private type declaration, - -- propagate it now to the full type declaration. + -- Check that ancestor interfaces of private and full views are + -- consistent. We omit this check for synchronized types because + -- they are performed on the corresponding record type when frozen. - if Is_CPP_Class (Priv_T) then - Set_Is_CPP_Class (Full_T); - Set_Convention (Full_T, Convention_CPP); + if Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Priv_T) + and then Is_Tagged_Type (Full_T) + and then not Is_Concurrent_Type (Full_T) + then + declare + Iface : Entity_Id; + Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; + Full_T_Ifaces : constant Elist_Id := New_Elmt_List; - -- Check that components of imported CPP types do not have default - -- expressions. + begin + Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); + Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); - Check_CPP_Type_Has_No_Defaults (Full_T); - end if; + -- 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)). - -- If the private view has user specified stream attributes, then so has - -- the full view. + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); - -- Why the test, how could these flags be already set in Full_T ??? + if Present (Iface) then + Error_Msg_NE + ("interface in partial view& not implemented by full type " + & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + end if; - if Has_Specified_Stream_Read (Priv_T) then - Set_Has_Specified_Stream_Read (Full_T); - end if; + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); - if Has_Specified_Stream_Write (Priv_T) then - Set_Has_Specified_Stream_Write (Full_T); + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial view " + & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + end if; + end; end if; - if Has_Specified_Stream_Input (Priv_T) then - Set_Has_Specified_Stream_Input (Full_T); - end if; + if Is_Tagged_Type (Priv_T) + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Is_Derived_Type (Full_T) + then + Priv_Parent := Etype (Priv_T); - if Has_Specified_Stream_Output (Priv_T) then - Set_Has_Specified_Stream_Output (Full_T); - end if; + -- The full view of a private extension may have been transformed + -- into an unconstrained derived type declaration and a subtype + -- declaration (see build_derived_record_type for details). - -- Propagate the attributes related to pragma Default_Initial_Condition - -- from the private to the full view. Note that both flags are mutually - -- exclusive. + if Nkind (N) = N_Subtype_Declaration then + Full_Indic := Subtype_Indication (N); + Full_Parent := Etype (Base_Type (Full_T)); + else + Full_Indic := Subtype_Indication (Type_Definition (N)); + Full_Parent := Etype (Full_T); + end if; - 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)); + -- Check that the parent type of the full type is a descendant of + -- the ancestor subtype given in the private extension. If either + -- entity has an Etype equal to Any_Type then we had some previous + -- error situation [7.3(8)]. - 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)); - end if; + if Priv_Parent = Any_Type or else Full_Parent = Any_Type then + return; - -- Propagate invariants to full type + -- Ada 2005 (AI-251): Interfaces in the full type can be given in + -- any order. Therefore we don't have to check that its parent must + -- be a descendant of the parent of the private type declaration. - if Has_Invariants (Priv_T) then - Set_Has_Invariants (Full_T); - Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); - end if; + elsif Is_Interface (Priv_Parent) + and then Is_Interface (Full_Parent) + then + null; - if Has_Inheritable_Invariants (Priv_T) then - Set_Has_Inheritable_Invariants (Full_T); - end if; + -- 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 are performed by Build_Derived_Record_Type. - -- Propagate predicates to full type, and predicate function if already - -- defined. It is not clear that this can actually happen? the partial - -- view cannot be frozen yet, and the predicate function has not been - -- built. Still it is a cheap check and seems safer to make it. + 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); + + -- First check a formal restriction, and then proceed with checking + -- Ada rules. Since the formal restriction is not a serious error, we + -- don't prevent further error detection for this check, hence the + -- ELSE. - if Has_Predicates (Priv_T) then - if Present (Predicate_Function (Priv_T)) then - Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); - end if; + else - Set_Has_Predicates (Full_T); - end if; - end Process_Full_View; + -- In formal mode, when completing a private extension the type + -- named in the private part must be exactly the same as that + -- named in the visible part. - ----------------------------------- - -- Process_Incomplete_Dependents -- - ----------------------------------- + if Priv_Parent /= Full_Parent then + Error_Msg_Name_1 := Chars (Priv_Parent); + Check_SPARK_05_Restriction ("% expected", Full_Indic); + end if; - procedure Process_Incomplete_Dependents - (N : Node_Id; - Full_T : Entity_Id; - Inc_T : Entity_Id) - is - Inc_Elmt : Elmt_Id; - Priv_Dep : Entity_Id; - New_Subt : Entity_Id; + -- Check the rules of 7.3(10): if the private extension inherits + -- known discriminants, then the full type must also inherit those + -- discriminants from the same (ancestor) type, and the parent + -- subtype of the full type must be constrained if and only if + -- the ancestor subtype of the private extension is constrained. - Disc_Constraint : Elist_Id; + if No (Discriminant_Specifications (Parent (Priv_T))) + and then not Has_Unknown_Discriminants (Priv_T) + and then Has_Discriminants (Base_Type (Priv_Parent)) + then + declare + Priv_Indic : constant Node_Id := + Subtype_Indication (Parent (Priv_T)); - begin - if No (Private_Dependents (Inc_T)) then - return; - end if; + Priv_Constr : constant Boolean := + Is_Constrained (Priv_Parent) + or else + Nkind (Priv_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Priv_Indic)); - -- Itypes that may be generated by the completion of an incomplete - -- subtype are not used by the back-end and not attached to the tree. - -- They are created only for constraint-checking purposes. + Full_Constr : constant Boolean := + Is_Constrained (Full_Parent) + or else + Nkind (Full_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Full_Indic)); - Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); - while Present (Inc_Elmt) loop - Priv_Dep := Node (Inc_Elmt); + Priv_Discr : Entity_Id; + Full_Discr : Entity_Id; - if Ekind (Priv_Dep) = E_Subprogram_Type then + begin + Priv_Discr := First_Discriminant (Priv_Parent); + Full_Discr := First_Discriminant (Full_Parent); + while Present (Priv_Discr) and then Present (Full_Discr) loop + if Original_Record_Component (Priv_Discr) = + Original_Record_Component (Full_Discr) + or else + Corresponding_Discriminant (Priv_Discr) = + Corresponding_Discriminant (Full_Discr) + then + null; + else + exit; + end if; - -- An Access_To_Subprogram type may have a return type or a - -- parameter type that is incomplete. Replace with the full view. + Next_Discriminant (Priv_Discr); + Next_Discriminant (Full_Discr); + end loop; - if Etype (Priv_Dep) = Inc_T then - Set_Etype (Priv_Dep, Full_T); - end if; + if Present (Priv_Discr) or else Present (Full_Discr) then + Error_Msg_N + ("full view must inherit discriminants of the parent" + & " type used in the private extension", Full_Indic); - declare - Formal : Entity_Id; + elsif Priv_Constr and then not Full_Constr then + Error_Msg_N + ("parent subtype of full type must be constrained", + Full_Indic); - begin - Formal := First_Formal (Priv_Dep); - while Present (Formal) loop - if Etype (Formal) = Inc_T then - Set_Etype (Formal, Full_T); + elsif Full_Constr and then not Priv_Constr then + Error_Msg_N + ("parent subtype of full type must be unconstrained", + Full_Indic); end if; + end; - Next_Formal (Formal); - end loop; - end; + -- Check the rules of 7.3(12): if a partial view has neither + -- known or unknown discriminants, then the full type + -- declaration shall define a definite subtype. - elsif Is_Overloadable (Priv_Dep) then + elsif not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then not Is_Constrained (Full_T) + then + Error_Msg_N + ("full view must define a constrained type if partial view" + & " has no discriminants", Full_T); + end if; - -- If a subprogram in the incomplete dependents list is primitive - -- for a tagged full type then mark it as a dispatching operation, - -- check whether it overrides an inherited subprogram, and check - -- restrictions on its controlling formals. Note that a protected - -- operation is never dispatching: only its wrapper operation - -- (which has convention Ada) is. + -- ??????? Do we implement the following properly ????? + -- If the ancestor subtype of a private extension has constrained + -- discriminants, then the parent subtype of the full view shall + -- impose a statically matching constraint on those discriminants + -- [7.3(13)]. + end if; - if Is_Tagged_Type (Full_T) - and then Is_Primitive (Priv_Dep) - and then Convention (Priv_Dep) /= Convention_Protected - then - Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); - Set_Is_Dispatching_Operation (Priv_Dep); - Check_Controlling_Formals (Full_T, Priv_Dep); + else + -- For untagged types, verify that a type without discriminants is + -- not completed with an unconstrained type. A separate error message + -- is produced if the full type has defaulted discriminants. + + if not Is_Indefinite_Subtype (Priv_T) + and then Is_Indefinite_Subtype (Full_T) + then + Error_Msg_Sloc := Sloc (Parent (Priv_T)); + Error_Msg_NE + ("full view of& not compatible with declaration#", + Full_T, Priv_T); + + if not Is_Tagged_Type (Full_T) then + Error_Msg_N + ("\one is constrained, the other unconstrained", Full_T); end if; + end if; + end if; - elsif Ekind (Priv_Dep) = E_Subprogram_Body then + -- AI-419: verify that the use of "limited" is consistent - -- Can happen during processing of a body before the completion - -- of a TA type. Ignore, because spec is also on dependent list. + declare + Orig_Decl : constant Node_Id := Original_Node (N); - return; + begin + if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then not Limited_Present (Parent (Priv_T)) + and then not Synchronized_Present (Parent (Priv_T)) + and then Nkind (Orig_Decl) = N_Full_Type_Declaration + and then Nkind + (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition + and then Limited_Present (Type_Definition (Orig_Decl)) + then + Error_Msg_N + ("full view of non-limited extension cannot be limited", N); + end if; + end; - -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a - -- corresponding subtype of the full view. + -- Ada 2005 (AI-443): A synchronized private extension must be + -- completed by a task or protected type. - elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then - Set_Subtype_Indication - (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); - Set_Etype (Priv_Dep, Full_T); - Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); - Set_Analyzed (Parent (Priv_Dep), False); + if Ada_Version >= Ada_2005 + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Synchronized_Present (Parent (Priv_T)) + and then not Is_Concurrent_Type (Full_T) + then + Error_Msg_N ("full view of synchronized extension must " & + "be synchronized type", N); + end if; - -- Reanalyze the declaration, suppressing the call to - -- Enter_Name to avoid duplicate names. + -- Ada 2005 AI-363: if the full view has discriminants with + -- defaults, it is illegal to declare constrained access subtypes + -- whose designated type is the current type. This allows objects + -- of the type that are declared in the heap to be unconstrained. - Analyze_Subtype_Declaration - (N => Parent (Priv_Dep), - Skip => True); + if not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then Has_Discriminants (Full_T) + and then + Present (Discriminant_Default_Value (First_Discriminant (Full_T))) + then + Set_Has_Constrained_Partial_View (Full_T); + Set_Has_Constrained_Partial_View (Priv_T); + end if; - -- Dependent is a subtype + -- Create a full declaration for all its subtypes recorded in + -- Private_Dependents and swap them similarly to the base type. These + -- are subtypes that have been define before the full declaration of + -- the private type. We also swap the entry in Private_Dependents list + -- so we can properly restore the private view on exit from the scope. - else - -- We build a new subtype indication using the full view of the - -- incomplete parent. The discriminant constraints have been - -- elaborated already at the point of the subtype declaration. + declare + Priv_Elmt : Elmt_Id; + Priv_Scop : Entity_Id; + Priv : Entity_Id; + Full : Entity_Id; - New_Subt := Create_Itype (E_Void, N); + begin + Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + Priv_Scop := Scope (Priv); - if Has_Discriminants (Full_T) then - Disc_Constraint := Discriminant_Constraint (Priv_Dep); - else - Disc_Constraint := No_Elist; - end if; + if Ekind_In (Priv, E_Private_Subtype, + E_Limited_Private_Subtype, + E_Record_Subtype_With_Private) + then + Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); + Set_Is_Itype (Full); + Set_Parent (Full, Parent (Priv)); + Set_Associated_Node_For_Itype (Full, N); + + -- Now we need to complete the private subtype, but since the + -- base type has already been swapped, we must also swap the + -- subtypes (and thus, reverse the arguments in the call to + -- Complete_Private_Subtype). Also note that we may need to + -- re-establish the scope of the private subtype. + + Copy_And_Swap (Priv, Full); - Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); - Set_Full_View (Priv_Dep, New_Subt); - end if; + if not In_Open_Scopes (Priv_Scop) then + Push_Scope (Priv_Scop); - Next_Elmt (Inc_Elmt); - end loop; - end Process_Incomplete_Dependents; + else + -- Reset Priv_Scop to Empty to indicate no scope was pushed - -------------------------------- - -- Process_Range_Expr_In_Decl -- - -------------------------------- + Priv_Scop := Empty; + end if; - procedure Process_Range_Expr_In_Decl - (R : Node_Id; - T : Entity_Id; - Subtyp : Entity_Id := Empty; - Check_List : List_Id := Empty_List; - R_Check_Off : Boolean := False; - In_Iter_Schm : Boolean := False) - is - Lo, Hi : Node_Id; - R_Checks : Check_Result; - Insert_Node : Node_Id; - Def_Id : Entity_Id; + Complete_Private_Subtype (Full, Priv, Full_T, N); - begin - Analyze_And_Resolve (R, Base_Type (T)); + if Present (Priv_Scop) then + Pop_Scope; + end if; - if Nkind (R) = N_Range then + Replace_Elmt (Priv_Elmt, Full); + end if; - -- In SPARK, all ranges should be static, with the exception of the - -- discrete type definition of a loop parameter specification. + Next_Elmt (Priv_Elmt); + end loop; + end; - if not In_Iter_Schm - and then not Is_OK_Static_Range (R) - then - Check_SPARK_05_Restriction ("range should be static", R); - end if; + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. - Lo := Low_Bound (R); - Hi := High_Bound (R); + if Is_Tagged_Type (Full_T) then + declare + Disp_Typ : Entity_Id; + Full_List : Elist_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; - -- We need to ensure validity of the bounds here, because if we - -- go ahead and do the expansion, then the expanded code will get - -- analyzed with range checks suppressed and we miss the check. - -- Validity checks on the range of a quantified expression are - -- delayed until the construct is transformed into a loop. + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E - if Nkind (Parent (R)) /= N_Loop_Parameter_Specification - or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression - then - Validity_Check_Range (R); - end if; + -------------- + -- Contains -- + -------------- - -- If there were errors in the declaration, try and patch up some - -- common mistakes in the bounds. The cases handled are literals - -- which are Integer where the expected type is Real and vice versa. - -- These corrections allow the compilation process to proceed further - -- along since some basic assumptions of the format of the bounds - -- are guaranteed. + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; - if Etype (R) = Any_Type then - if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then - Rewrite (Lo, - Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; - elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then - Rewrite (Hi, - Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); + Next_Elmt (List_Elmt); + end loop; - elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then - Rewrite (Lo, - Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); + return False; + end Contains; - elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then - Rewrite (Hi, - Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); - end if; + -- Start of processing - Set_Etype (Lo, T); - Set_Etype (Hi, T); - end if; + begin + if Is_Tagged_Type (Priv_T) then + Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); - -- If the bounds of the range have been mistakenly given as string - -- literals (perhaps in place of character literals), then an error - -- has already been reported, but we rewrite the string literal as a - -- bound of the range's type to avoid blowups in later processing - -- that looks at static values. + -- In the case of a concurrent type completing a private tagged + -- type, primitives may have been declared in between the two + -- views. These subprograms need to be wrapped the same way + -- entries and protected procedures are handled because they + -- cannot be directly shared by the two views. - if Nkind (Lo) = N_String_Literal then - Rewrite (Lo, - Make_Attribute_Reference (Sloc (Lo), - Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (T, Sloc (Lo)))); - Analyze_And_Resolve (Lo); - end if; + if Is_Concurrent_Type (Full_T) then + declare + Conc_Typ : constant Entity_Id := + Corresponding_Record_Type (Full_T); + Curr_Nod : Node_Id := Parent (Conc_Typ); + Wrap_Spec : Node_Id; - if Nkind (Hi) = N_String_Literal then - Rewrite (Hi, - Make_Attribute_Reference (Sloc (Hi), - Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (T, Sloc (Hi)))); - Analyze_And_Resolve (Hi); - end if; + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - -- If bounds aren't scalar at this point then exit, avoiding - -- problems with further processing of the range in this procedure. + if Comes_From_Source (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Wrap_Spec := + Make_Subprogram_Declaration (Sloc (Prim), + Specification => + Build_Wrapper_Spec + (Subp_Id => Prim, + Obj_Typ => Conc_Typ, + Formals => + Parameter_Specifications ( + Parent (Prim)))); - if not Is_Scalar_Type (Etype (Lo)) then - return; - end if; + Insert_After (Curr_Nod, Wrap_Spec); + Curr_Nod := Wrap_Spec; - -- Resolve (actually Sem_Eval) has checked that the bounds are in - -- then range of the base type. Here we check whether the bounds - -- are in the range of the subtype itself. Note that if the bounds - -- represent the null range the Constraint_Error exception should - -- not be raised. + Analyze (Wrap_Spec); + end if; - -- ??? The following code should be cleaned up as follows + Next_Elmt (Prim_Elmt); + end loop; - -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it - -- is done in the call to Range_Check (R, T); below + return; + end; - -- 2. The use of R_Check_Off should be investigated and possibly - -- removed, this would clean up things a bit. + -- For non-concurrent types, transfer explicit primitives, but + -- omit those inherited from the parent of the private view + -- since they will be re-inherited later on. - if Is_Null_Range (Lo, Hi) then - null; + else + Full_List := Primitive_Operations (Full_T); - else - -- Capture values of bounds and generate temporaries for them - -- if needed, before applying checks, since checks may cause - -- duplication of the expression without forcing evaluation. + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - -- The forced evaluation removes side effects from expressions, - -- which should occur also in GNATprove mode. Otherwise, we end up - -- with unexpected insertions of actions at places where this is - -- not supposed to occur, e.g. on default parameters of a call. + if Comes_From_Source (Prim) + and then not Contains (Prim, Full_List) + then + Append_Elmt (Prim, Full_List); + end if; - if Expander_Active or GNATprove_Mode then + Next_Elmt (Prim_Elmt); + end loop; + end if; - -- If no subtype name, then just call Force_Evaluation to - -- create declarations as needed to deal with side effects. - -- Also ignore calls from within a record type, where we - -- have possible scoping issues. + -- Untagged private view - if No (Subtyp) or else Is_Record_Type (Current_Scope) then - Force_Evaluation (Lo); - Force_Evaluation (Hi); + else + Full_List := Primitive_Operations (Full_T); - -- If a subtype is given, then we capture the bounds if they - -- are not known at compile time, using constant identifiers - -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype. + -- In this case the partial view is untagged, so here we locate + -- all of the earlier primitives that need to be treated as + -- dispatching (those that appear between the two views). Note + -- that these additional operations must all be new operations + -- (any earlier operations that override inherited operations + -- of the full view will already have been inserted in the + -- primitives list, marked by Check_Operation_From_Private_View + -- as dispatching. Note that implicit "/=" operators are + -- excluded from being added to the primitives list since they + -- shouldn't be treated as dispatching (tagged "/=" is handled + -- specially). - -- Note: we do this transformation even if expansion is not - -- active, and in particular we do it in GNATprove_Mode since - -- the transformation is in general required to ensure that the - -- resulting tree has proper Ada semantics. + Prim := Next_Entity (Full_T); + while Present (Prim) and then Prim /= Priv_T loop + if Ekind_In (Prim, E_Procedure, E_Function) then + Disp_Typ := Find_Dispatching_Type (Prim); - -- Historical note: We used to just do Force_Evaluation calls - -- in all cases, but it is better to capture the bounds with - -- proper non-serialized names, since these will be accessed - -- from other units, and hence may be public, and also we can - -- then expand 'First and 'Last references to be references to - -- these special names. + if Disp_Typ = Full_T + and then (Chars (Prim) /= Name_Op_Ne + or else Comes_From_Source (Prim)) + then + Check_Controlling_Formals (Full_T, Prim); + + if not Is_Dispatching_Operation (Prim) then + Append_Elmt (Prim, Full_List); + Set_Is_Dispatching_Operation (Prim, True); + Set_DT_Position (Prim, No_Uint); + end if; - else - if not Compile_Time_Known_Value (Lo) + elsif Is_Dispatching_Operation (Prim) + and then Disp_Typ /= Full_T + then - -- No need to capture bounds if they already are - -- references to constants. + -- Verify that it is not otherwise controlled by a + -- formal or a return value of type T. - and then not (Is_Entity_Name (Lo) - and then Is_Constant_Object (Entity (Lo))) - then - declare - Loc : constant Source_Ptr := Sloc (Lo); - Lov : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subtyp), "_FIRST")); - begin - Insert_Action (R, - Make_Object_Declaration (Loc, - Defining_Identifier => Lov, - Object_Definition => - New_Occurrence_Of (Base_Type (T), Loc), - Constant_Present => True, - Expression => Relocate_Node (Lo))); - Rewrite (Lo, New_Occurrence_Of (Lov, Loc)); - end; + Check_Controlling_Formals (Disp_Typ, Prim); + end if; end if; - if not Compile_Time_Known_Value (Hi) - and then not (Is_Entity_Name (Hi) - and then Is_Constant_Object (Entity (Hi))) - then - declare - Loc : constant Source_Ptr := Sloc (Hi); - Hiv : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subtyp), "_LAST")); - begin - Insert_Action (R, - Make_Object_Declaration (Loc, - Defining_Identifier => Hiv, - Object_Definition => - New_Occurrence_Of (Base_Type (T), Loc), - Constant_Present => True, - Expression => Relocate_Node (Hi))); - Rewrite (Hi, New_Occurrence_Of (Hiv, Loc)); - end; - end if; - end if; + Next_Entity (Prim); + end loop; end if; - -- We use a flag here instead of suppressing checks on the - -- type because the type we check against isn't necessarily - -- the place where we put the check. + -- For the tagged case, the two views can share the same primitive + -- operations list and the same class-wide type. Update attributes + -- of the class-wide type which depend on the full declaration. - if not R_Check_Off then - R_Checks := Get_Range_Checks (R, T); + if Is_Tagged_Type (Priv_T) then + Set_Direct_Primitive_Operations (Priv_T, Full_List); + Set_Class_Wide_Type + (Base_Type (Full_T), Class_Wide_Type (Priv_T)); - -- Look up tree to find an appropriate insertion point. We - -- can't just use insert_actions because later processing - -- depends on the insertion node. Prior to Ada 2012 the - -- insertion point could only be a declaration or a loop, but - -- quantified expressions can appear within any context in an - -- expression, and the insertion point can be any statement, - -- pragma, or declaration. + Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); + Set_Has_Protected + (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); + end if; + end; + end if; - Insert_Node := Parent (R); - while Present (Insert_Node) loop - exit when - Nkind (Insert_Node) in N_Declaration - and then - not Nkind_In - (Insert_Node, N_Component_Declaration, - N_Loop_Parameter_Specification, - N_Function_Specification, - N_Procedure_Specification); + -- Ada 2005 AI 161: Check preelaborable initialization consistency - exit when Nkind (Insert_Node) in N_Later_Decl_Item - or else Nkind (Insert_Node) in - N_Statement_Other_Than_Procedure_Call - or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, - N_Pragma); + if Known_To_Have_Preelab_Init (Priv_T) then - Insert_Node := Parent (Insert_Node); - end loop; + -- Case where there is a pragma Preelaborable_Initialization. We + -- always allow this in predefined units, which is cheating a bit, + -- but it means we don't have to struggle to meet the requirements in + -- the RM for having Preelaborable Initialization. Otherwise we + -- require that the type meets the RM rules. But we can't check that + -- yet, because of the rule about overriding Initialize, so we simply + -- set a flag that will be checked at freeze time. - -- Why would Type_Decl not be present??? Without this test, - -- short regression tests fail. + if not In_Predefined_Unit (Full_T) then + Set_Must_Have_Preelab_Init (Full_T); + end if; + end if; - if Present (Insert_Node) then + -- If pragma CPP_Class was applied to the private type declaration, + -- propagate it now to the full type declaration. - -- Case of loop statement. Verify that the range is part - -- of the subtype indication of the iteration scheme. + if Is_CPP_Class (Priv_T) then + Set_Is_CPP_Class (Full_T); + Set_Convention (Full_T, Convention_CPP); - if Nkind (Insert_Node) = N_Loop_Statement then - declare - Indic : Node_Id; + -- Check that components of imported CPP types do not have default + -- expressions. - begin - Indic := Parent (R); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; + Check_CPP_Type_Has_No_Defaults (Full_T); + end if; - if Present (Indic) then - Def_Id := Etype (Subtype_Mark (Indic)); + -- If the private view has user specified stream attributes, then so has + -- the full view. - Insert_Range_Checks - (R_Checks, - Insert_Node, - Def_Id, - Sloc (Insert_Node), - R, - Do_Before => True); - end if; - end; + -- Why the test, how could these flags be already set in Full_T ??? - -- Insertion before a declaration. If the declaration - -- includes discriminants, the list of applicable checks - -- is given by the caller. + if Has_Specified_Stream_Read (Priv_T) then + Set_Has_Specified_Stream_Read (Full_T); + end if; - elsif Nkind (Insert_Node) in N_Declaration then - Def_Id := Defining_Identifier (Insert_Node); + if Has_Specified_Stream_Write (Priv_T) then + Set_Has_Specified_Stream_Write (Full_T); + end if; - if (Ekind (Def_Id) = E_Record_Type - and then Depends_On_Discriminant (R)) - or else - (Ekind (Def_Id) = E_Protected_Type - and then Has_Discriminants (Def_Id)) - then - Append_Range_Checks - (R_Checks, - Check_List, Def_Id, Sloc (Insert_Node), R); + if Has_Specified_Stream_Input (Priv_T) then + Set_Has_Specified_Stream_Input (Full_T); + end if; - else - Insert_Range_Checks - (R_Checks, - Insert_Node, Def_Id, Sloc (Insert_Node), R); + if Has_Specified_Stream_Output (Priv_T) then + Set_Has_Specified_Stream_Output (Full_T); + end if; - end if; + -- Propagate the attributes related to pragma Default_Initial_Condition + -- from the private to the full view. Note that both flags are mutually + -- exclusive. - -- Insertion before a statement. Range appears in the - -- context of a quantified expression. Insertion will - -- take place when expression is expanded. + 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); + + -- 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; - else - null; - end if; - end if; - end if; + -- Propagate invariants to full type + + if Has_Invariants (Priv_T) then + Set_Has_Invariants (Full_T); + Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); + end if; + + if Has_Inheritable_Invariants (Priv_T) then + Set_Has_Inheritable_Invariants (Full_T); + end if; + + -- Propagate predicates to full type, and predicate function if already + -- defined. It is not clear that this can actually happen? the partial + -- view cannot be frozen yet, and the predicate function has not been + -- built. Still it is a cheap check and seems safer to make it. + + if Has_Predicates (Priv_T) then + if Present (Predicate_Function (Priv_T)) then + Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); end if; - -- Case of other than an explicit N_Range node + Set_Has_Predicates (Full_T); + end if; + end Process_Full_View; - -- The forced evaluation removes side effects from expressions, which - -- should occur also in GNATprove mode. Otherwise, we end up with - -- unexpected insertions of actions at places where this is not - -- supposed to occur, e.g. on default parameters of a call. + ----------------------------------- + -- Process_Incomplete_Dependents -- + ----------------------------------- - elsif Expander_Active or GNATprove_Mode then - Get_Index_Bounds (R, Lo, Hi); - Force_Evaluation (Lo); - Force_Evaluation (Hi); + procedure Process_Incomplete_Dependents + (N : Node_Id; + Full_T : Entity_Id; + Inc_T : Entity_Id) + is + Inc_Elmt : Elmt_Id; + Priv_Dep : Entity_Id; + New_Subt : Entity_Id; + + Disc_Constraint : Elist_Id; + + begin + if No (Private_Dependents (Inc_T)) then + return; end if; - end Process_Range_Expr_In_Decl; - -------------------------------------- - -- Process_Real_Range_Specification -- - -------------------------------------- + -- Itypes that may be generated by the completion of an incomplete + -- subtype are not used by the back-end and not attached to the tree. + -- They are created only for constraint-checking purposes. - procedure Process_Real_Range_Specification (Def : Node_Id) is - Spec : constant Node_Id := Real_Range_Specification (Def); - Lo : Node_Id; - Hi : Node_Id; - Err : Boolean := False; + Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); + while Present (Inc_Elmt) loop + Priv_Dep := Node (Inc_Elmt); - procedure Analyze_Bound (N : Node_Id); - -- Analyze and check one bound + if Ekind (Priv_Dep) = E_Subprogram_Type then - ------------------- - -- Analyze_Bound -- - ------------------- + -- An Access_To_Subprogram type may have a return type or a + -- parameter type that is incomplete. Replace with the full view. - procedure Analyze_Bound (N : Node_Id) is - begin - Analyze_And_Resolve (N, Any_Real); + if Etype (Priv_Dep) = Inc_T then + Set_Etype (Priv_Dep, Full_T); + end if; - if not Is_OK_Static_Expression (N) then - Flag_Non_Static_Expr - ("bound in real type definition is not static!", N); - Err := True; - end if; - end Analyze_Bound; + declare + Formal : Entity_Id; - -- Start of processing for Process_Real_Range_Specification + begin + Formal := First_Formal (Priv_Dep); + while Present (Formal) loop + if Etype (Formal) = Inc_T then + Set_Etype (Formal, Full_T); + end if; - begin - if Present (Spec) then - Lo := Low_Bound (Spec); - Hi := High_Bound (Spec); - Analyze_Bound (Lo); - Analyze_Bound (Hi); + Next_Formal (Formal); + end loop; + end; - -- If error, clear away junk range specification + elsif Is_Overloadable (Priv_Dep) then - if Err then - Set_Real_Range_Specification (Def, Empty); - end if; - end if; - end Process_Real_Range_Specification; + -- If a subprogram in the incomplete dependents list is primitive + -- for a tagged full type then mark it as a dispatching operation, + -- check whether it overrides an inherited subprogram, and check + -- restrictions on its controlling formals. Note that a protected + -- operation is never dispatching: only its wrapper operation + -- (which has convention Ada) is. - --------------------- - -- Process_Subtype -- - --------------------- + if Is_Tagged_Type (Full_T) + and then Is_Primitive (Priv_Dep) + and then Convention (Priv_Dep) /= Convention_Protected + then + Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); + Set_Is_Dispatching_Operation (Priv_Dep); + Check_Controlling_Formals (Full_T, Priv_Dep); + end if; - function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id - is - P : Node_Id; - Def_Id : Entity_Id; - Error_Node : Node_Id; - Full_View_Id : Entity_Id; - Subtype_Mark_Id : Entity_Id; + elsif Ekind (Priv_Dep) = E_Subprogram_Body then - May_Have_Null_Exclusion : Boolean; + -- Can happen during processing of a body before the completion + -- of a TA type. Ignore, because spec is also on dependent list. - procedure Check_Incomplete (T : Entity_Id); - -- Called to verify that an incomplete type is not used prematurely + return; - ---------------------- - -- Check_Incomplete -- - ---------------------- + -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a + -- corresponding subtype of the full view. - procedure Check_Incomplete (T : Entity_Id) is - begin - -- Ada 2005 (AI-412): Incomplete subtypes are legal + elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then + Set_Subtype_Indication + (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); + Set_Etype (Priv_Dep, Full_T); + Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); + Set_Analyzed (Parent (Priv_Dep), False); - if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type - and then - not (Ada_Version >= Ada_2005 - and then - (Nkind (Parent (T)) = N_Subtype_Declaration - or else - (Nkind (Parent (T)) = N_Subtype_Indication - and then Nkind (Parent (Parent (T))) = - N_Subtype_Declaration))) - then - Error_Msg_N ("invalid use of type before its full declaration", T); - end if; - end Check_Incomplete; + -- Reanalyze the declaration, suppressing the call to + -- Enter_Name to avoid duplicate names. - -- Start of processing for Process_Subtype + Analyze_Subtype_Declaration + (N => Parent (Priv_Dep), + Skip => True); - begin - -- Case of no constraints present + -- Dependent is a subtype - if Nkind (S) /= N_Subtype_Indication then - Find_Type (S); - Check_Incomplete (S); - P := Parent (S); + else + -- We build a new subtype indication using the full view of the + -- incomplete parent. The discriminant constraints have been + -- elaborated already at the point of the subtype declaration. - -- Ada 2005 (AI-231): Static check + New_Subt := Create_Itype (E_Void, N); - if Ada_Version >= Ada_2005 - and then Present (P) - and then Null_Exclusion_Present (P) - and then Nkind (P) /= N_Access_To_Object_Definition - and then not Is_Access_Type (Entity (S)) - then - Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + if Has_Discriminants (Full_T) then + Disc_Constraint := Discriminant_Constraint (Priv_Dep); + else + Disc_Constraint := No_Elist; + end if; + + Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); + Set_Full_View (Priv_Dep, New_Subt); end if; - -- The following is ugly, can't we have a range or even a flag??? + Next_Elmt (Inc_Elmt); + end loop; + end Process_Incomplete_Dependents; - May_Have_Null_Exclusion := - Nkind_In (P, N_Access_Definition, - N_Access_Function_Definition, - N_Access_Procedure_Definition, - N_Access_To_Object_Definition, - N_Allocator, - N_Component_Definition) - or else - Nkind_In (P, N_Derived_Type_Definition, - N_Discriminant_Specification, - N_Formal_Object_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Parameter_Specification, - N_Subtype_Declaration); + -------------------------------- + -- Process_Range_Expr_In_Decl -- + -------------------------------- - -- Create an Itype that is a duplicate of Entity (S) but with the - -- null-exclusion attribute. + procedure Process_Range_Expr_In_Decl + (R : Node_Id; + T : Entity_Id; + Subtyp : Entity_Id := Empty; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False; + In_Iter_Schm : Boolean := False) + is + Lo, Hi : Node_Id; + R_Checks : Check_Result; + Insert_Node : Node_Id; + Def_Id : Entity_Id; - if May_Have_Null_Exclusion - and then Is_Access_Type (Entity (S)) - and then Null_Exclusion_Present (P) + begin + Analyze_And_Resolve (R, Base_Type (T)); - -- No need to check the case of an access to object definition. - -- It is correct to define double not-null pointers. + if Nkind (R) = N_Range then - -- Example: - -- type Not_Null_Int_Ptr is not null access Integer; - -- type Acc is not null access Not_Null_Int_Ptr; + -- In SPARK, all ranges should be static, with the exception of the + -- discrete type definition of a loop parameter specification. - and then Nkind (P) /= N_Access_To_Object_Definition + if not In_Iter_Schm + and then not Is_OK_Static_Range (R) then - if Can_Never_Be_Null (Entity (S)) then - case Nkind (Related_Nod) is - when N_Full_Type_Declaration => - if Nkind (Type_Definition (Related_Nod)) - in N_Array_Type_Definition - then - Error_Node := - Subtype_Indication - (Component_Definition - (Type_Definition (Related_Nod))); - else - Error_Node := - Subtype_Indication (Type_Definition (Related_Nod)); - end if; + Check_SPARK_05_Restriction ("range should be static", R); + end if; - when N_Subtype_Declaration => - Error_Node := Subtype_Indication (Related_Nod); + Lo := Low_Bound (R); + Hi := High_Bound (R); - when N_Object_Declaration => - Error_Node := Object_Definition (Related_Nod); + -- We need to ensure validity of the bounds here, because if we + -- go ahead and do the expansion, then the expanded code will get + -- analyzed with range checks suppressed and we miss the check. + -- Validity checks on the range of a quantified expression are + -- delayed until the construct is transformed into a loop. - when N_Component_Declaration => - Error_Node := - Subtype_Indication (Component_Definition (Related_Nod)); + if Nkind (Parent (R)) /= N_Loop_Parameter_Specification + or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression + then + Validity_Check_Range (R); + end if; - when N_Allocator => - Error_Node := Expression (Related_Nod); + -- If there were errors in the declaration, try and patch up some + -- common mistakes in the bounds. The cases handled are literals + -- which are Integer where the expected type is Real and vice versa. + -- These corrections allow the compilation process to proceed further + -- along since some basic assumptions of the format of the bounds + -- are guaranteed. - when others => - pragma Assert (False); - Error_Node := Related_Nod; - end case; + if Etype (R) = Any_Type then + if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Lo, + Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Error_Node, - Entity (S)); + elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Hi, + Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); + + elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Lo, + Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); + + elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Hi, + Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); end if; - Set_Etype (S, - Create_Null_Excluding_Itype - (T => Entity (S), - Related_Nod => P)); - Set_Entity (S, Etype (S)); + Set_Etype (Lo, T); + Set_Etype (Hi, T); end if; - return Entity (S); - - -- Case of constraint present, so that we have an N_Subtype_Indication - -- node (this node is created only if constraints are present). + -- If the bounds of the range have been mistakenly given as string + -- literals (perhaps in place of character literals), then an error + -- has already been reported, but we rewrite the string literal as a + -- bound of the range's type to avoid blowups in later processing + -- that looks at static values. - else - Find_Type (Subtype_Mark (S)); + if Nkind (Lo) = N_String_Literal then + Rewrite (Lo, + Make_Attribute_Reference (Sloc (Lo), + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (T, Sloc (Lo)))); + Analyze_And_Resolve (Lo); + end if; - if Nkind (Parent (S)) /= N_Access_To_Object_Definition - and then not - (Nkind (Parent (S)) = N_Subtype_Declaration - and then Is_Itype (Defining_Identifier (Parent (S)))) - then - Check_Incomplete (Subtype_Mark (S)); + if Nkind (Hi) = N_String_Literal then + Rewrite (Hi, + Make_Attribute_Reference (Sloc (Hi), + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (T, Sloc (Hi)))); + Analyze_And_Resolve (Hi); end if; - P := Parent (S); - Subtype_Mark_Id := Entity (Subtype_Mark (S)); + -- If bounds aren't scalar at this point then exit, avoiding + -- problems with further processing of the range in this procedure. - -- Explicit subtype declaration case + if not Is_Scalar_Type (Etype (Lo)) then + return; + end if; - if Nkind (P) = N_Subtype_Declaration then - Def_Id := Defining_Identifier (P); + -- Resolve (actually Sem_Eval) has checked that the bounds are in + -- then range of the base type. Here we check whether the bounds + -- are in the range of the subtype itself. Note that if the bounds + -- represent the null range the Constraint_Error exception should + -- not be raised. - -- Explicit derived type definition case + -- ??? The following code should be cleaned up as follows - elsif Nkind (P) = N_Derived_Type_Definition then - Def_Id := Defining_Identifier (Parent (P)); + -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it + -- is done in the call to Range_Check (R, T); below - -- Implicit case, the Def_Id must be created as an implicit type. - -- The one exception arises in the case of concurrent types, array - -- and access types, where other subsidiary implicit types may be - -- created and must appear before the main implicit type. In these - -- cases we leave Def_Id set to Empty as a signal that Create_Itype - -- has not yet been called to create Def_Id. + -- 2. The use of R_Check_Off should be investigated and possibly + -- removed, this would clean up things a bit. + + if Is_Null_Range (Lo, Hi) then + null; else - if Is_Array_Type (Subtype_Mark_Id) - or else Is_Concurrent_Type (Subtype_Mark_Id) - or else Is_Access_Type (Subtype_Mark_Id) - then - Def_Id := Empty; + -- Capture values of bounds and generate temporaries for them + -- if needed, before applying checks, since checks may cause + -- duplication of the expression without forcing evaluation. - -- For the other cases, we create a new unattached Itype, - -- and set the indication to ensure it gets attached later. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in GNATprove mode. Otherwise, we end up + -- with unexpected insertions of actions at places where this is + -- not supposed to occur, e.g. on default parameters of a call. - else - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; - end if; + if Expander_Active or GNATprove_Mode then - -- If the kind of constraint is invalid for this kind of type, - -- then give an error, and then pretend no constraint was given. + -- If no subtype name, then just call Force_Evaluation to + -- create declarations as needed to deal with side effects. + -- Also ignore calls from within a record type, where we + -- have possible scoping issues. - if not Is_Valid_Constraint_Kind - (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) - then - Error_Msg_N - ("incorrect constraint for this kind of type", Constraint (S)); + if No (Subtyp) or else Is_Record_Type (Current_Scope) then + Force_Evaluation (Lo); + Force_Evaluation (Hi); - Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); + -- If a subtype is given, then we capture the bounds if they + -- are not known at compile time, using constant identifiers + -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype. - -- Set Ekind of orphan itype, to prevent cascaded errors + -- Note: we do this transformation even if expansion is not + -- active, and in particular we do it in GNATprove_Mode since + -- the transformation is in general required to ensure that the + -- resulting tree has proper Ada semantics. - if Present (Def_Id) then - Set_Ekind (Def_Id, Ekind (Any_Type)); + -- Historical note: We used to just do Force_Evaluation calls + -- in all cases, but it is better to capture the bounds with + -- proper non-serialized names, since these will be accessed + -- from other units, and hence may be public, and also we can + -- then expand 'First and 'Last references to be references to + -- these special names. + + else + if not Compile_Time_Known_Value (Lo) + + -- No need to capture bounds if they already are + -- references to constants. + + and then not (Is_Entity_Name (Lo) + and then Is_Constant_Object (Entity (Lo))) + then + declare + Loc : constant Source_Ptr := Sloc (Lo); + Lov : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_FIRST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Lov, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Lo))); + Rewrite (Lo, New_Occurrence_Of (Lov, Loc)); + end; + end if; + + if not Compile_Time_Known_Value (Hi) + and then not (Is_Entity_Name (Hi) + and then Is_Constant_Object (Entity (Hi))) + then + declare + Loc : constant Source_Ptr := Sloc (Hi); + Hiv : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_LAST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Hiv, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Hi))); + Rewrite (Hi, New_Occurrence_Of (Hiv, Loc)); + end; + end if; + end if; end if; - -- Make recursive call, having got rid of the bogus constraint + -- We use a flag here instead of suppressing checks on the + -- type because the type we check against isn't necessarily + -- the place where we put the check. - return Process_Subtype (S, Related_Nod, Related_Id, Suffix); - end if; + if not R_Check_Off then + R_Checks := Get_Range_Checks (R, T); - -- Remaining processing depends on type. Select on Base_Type kind to - -- ensure getting to the concrete type kind in the case of a private - -- subtype (needed when only doing semantic analysis). + -- Look up tree to find an appropriate insertion point. We + -- can't just use insert_actions because later processing + -- depends on the insertion node. Prior to Ada 2012 the + -- insertion point could only be a declaration or a loop, but + -- quantified expressions can appear within any context in an + -- expression, and the insertion point can be any statement, + -- pragma, or declaration. - case Ekind (Base_Type (Subtype_Mark_Id)) is - when Access_Kind => + Insert_Node := Parent (R); + while Present (Insert_Node) loop + exit when + Nkind (Insert_Node) in N_Declaration + and then + not Nkind_In + (Insert_Node, N_Component_Declaration, + N_Loop_Parameter_Specification, + N_Function_Specification, + N_Procedure_Specification); - -- If this is a constraint on a class-wide type, discard it. - -- There is currently no way to express a partial discriminant - -- constraint on a type with unknown discriminants. This is - -- a pathology that the ACATS wisely decides not to test. + exit when Nkind (Insert_Node) in N_Later_Decl_Item + or else Nkind (Insert_Node) in + N_Statement_Other_Than_Procedure_Call + or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, + N_Pragma); - if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then - if Comes_From_Source (S) then - Error_Msg_N - ("constraint on class-wide type ignored??", - Constraint (S)); - end if; + Insert_Node := Parent (Insert_Node); + end loop; - if Nkind (P) = N_Subtype_Declaration then - Set_Subtype_Indication (P, - New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); - end if; + -- Why would Type_Decl not be present??? Without this test, + -- short regression tests fail. - return Subtype_Mark_Id; - end if; + if Present (Insert_Node) then - Constrain_Access (Def_Id, S, Related_Nod); + -- Case of loop statement. Verify that the range is part + -- of the subtype indication of the iteration scheme. - if Expander_Active - and then Is_Itype (Designated_Type (Def_Id)) - and then Nkind (Related_Nod) = N_Subtype_Declaration - and then not Is_Incomplete_Type (Designated_Type (Def_Id)) - then - Build_Itype_Reference - (Designated_Type (Def_Id), Related_Nod); - end if; + if Nkind (Insert_Node) = N_Loop_Statement then + declare + Indic : Node_Id; + + begin + Indic := Parent (R); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; + + if Present (Indic) then + Def_Id := Etype (Subtype_Mark (Indic)); - when Array_Kind => - Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); + Insert_Range_Checks + (R_Checks, + Insert_Node, + Def_Id, + Sloc (Insert_Node), + R, + Do_Before => True); + end if; + end; - when Decimal_Fixed_Point_Kind => - Constrain_Decimal (Def_Id, S); + -- Insertion before a declaration. If the declaration + -- includes discriminants, the list of applicable checks + -- is given by the caller. - when Enumeration_Kind => - Constrain_Enumeration (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); + elsif Nkind (Insert_Node) in N_Declaration then + Def_Id := Defining_Identifier (Insert_Node); - when Ordinary_Fixed_Point_Kind => - Constrain_Ordinary_Fixed (Def_Id, S); + if (Ekind (Def_Id) = E_Record_Type + and then Depends_On_Discriminant (R)) + or else + (Ekind (Def_Id) = E_Protected_Type + and then Has_Discriminants (Def_Id)) + then + Append_Range_Checks + (R_Checks, + Check_List, Def_Id, Sloc (Insert_Node), R); - when Float_Kind => - Constrain_Float (Def_Id, S); + else + Insert_Range_Checks + (R_Checks, + Insert_Node, Def_Id, Sloc (Insert_Node), R); - when Integer_Kind => - Constrain_Integer (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); + end if; - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type => - Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + -- Insertion before a statement. Range appears in the + -- context of a quantified expression. Insertion will + -- take place when expression is expanded. - if Ekind (Def_Id) = E_Incomplete_Type then - Set_Private_Dependents (Def_Id, New_Elmt_List); + else + null; + end if; end if; + end if; + end if; - when Private_Kind => - Constrain_Discriminated_Type (Def_Id, S, Related_Nod); - Set_Private_Dependents (Def_Id, New_Elmt_List); - - -- In case of an invalid constraint prevent further processing - -- since the type constructed is missing expected fields. + -- Case of other than an explicit N_Range node - if Etype (Def_Id) = Any_Type then - return Def_Id; - end if; + -- The forced evaluation removes side effects from expressions, which + -- should occur also in GNATprove mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. - -- If the full view is that of a task with discriminants, - -- we must constrain both the concurrent type and its - -- corresponding record type. Otherwise we will just propagate - -- the constraint to the full view, if available. + elsif Expander_Active or GNATprove_Mode then + Get_Index_Bounds (R, Lo, Hi); + Force_Evaluation (Lo); + Force_Evaluation (Hi); + end if; + end Process_Range_Expr_In_Decl; - if Present (Full_View (Subtype_Mark_Id)) - and then Has_Discriminants (Subtype_Mark_Id) - and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) - then - Full_View_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + -------------------------------------- + -- Process_Real_Range_Specification -- + -------------------------------------- - Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); - Constrain_Concurrent (Full_View_Id, S, - Related_Nod, Related_Id, Suffix); - Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); - Set_Full_View (Def_Id, Full_View_Id); + procedure Process_Real_Range_Specification (Def : Node_Id) is + Spec : constant Node_Id := Real_Range_Specification (Def); + Lo : Node_Id; + Hi : Node_Id; + Err : Boolean := False; - -- Introduce an explicit reference to the private subtype, - -- to prevent scope anomalies in gigi if first use appears - -- in a nested context, e.g. a later function body. - -- Should this be generated in other contexts than a full - -- type declaration? + procedure Analyze_Bound (N : Node_Id); + -- Analyze and check one bound - if Is_Itype (Def_Id) - and then - Nkind (Parent (P)) = N_Full_Type_Declaration - then - Build_Itype_Reference (Def_Id, Parent (P)); - end if; + ------------------- + -- Analyze_Bound -- + ------------------- - else - Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); - end if; + procedure Analyze_Bound (N : Node_Id) is + begin + Analyze_And_Resolve (N, Any_Real); - when Concurrent_Kind => - Constrain_Concurrent (Def_Id, S, - Related_Nod, Related_Id, Suffix); + if not Is_OK_Static_Expression (N) then + Flag_Non_Static_Expr + ("bound in real type definition is not static!", N); + Err := True; + end if; + end Analyze_Bound; - when others => - Error_Msg_N ("invalid subtype mark in subtype indication", S); - end case; + -- Start of processing for Process_Real_Range_Specification - -- Size and Convention are always inherited from the base type + begin + if Present (Spec) then + Lo := Low_Bound (Spec); + Hi := High_Bound (Spec); + Analyze_Bound (Lo); + Analyze_Bound (Hi); - Set_Size_Info (Def_Id, (Subtype_Mark_Id)); - Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); + -- If error, clear away junk range specification - return Def_Id; + if Err then + Set_Real_Range_Specification (Def, Empty); + end if; end if; - end Process_Subtype; + end Process_Real_Range_Specification; - --------------------------------------- - -- Check_Anonymous_Access_Components -- - --------------------------------------- + --------------------- + -- Process_Subtype -- + --------------------- - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id) + function Process_Subtype + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' ') return Entity_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; + P : Node_Id; + Def_Id : Entity_Id; + Error_Node : Node_Id; + Full_View_Id : Entity_Id; + Subtype_Mark_Id : Entity_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. + May_Have_Null_Exclusion : Boolean; - function Designates_T (Subt : Node_Id) return Boolean; - -- Check whether a node designates the enclosing record type, or 'Class - -- of that type + procedure Check_Incomplete (T : Entity_Id); + -- Called to verify that an incomplete type is not used prematurely - 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. + ---------------------- + -- Check_Incomplete -- + ---------------------- - -------------------------------------- - -- Build_Incomplete_Type_Declaration -- - -------------------------------------- + procedure Check_Incomplete (T : Entity_Id) is + begin + -- Ada 2005 (AI-412): Incomplete subtypes are legal - procedure Build_Incomplete_Type_Declaration is - Decl : Node_Id; - Inc_T : Entity_Id; - H : Entity_Id; + if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type + and then + not (Ada_Version >= Ada_2005 + and then + (Nkind (Parent (T)) = N_Subtype_Declaration + or else + (Nkind (Parent (T)) = N_Subtype_Indication + and then Nkind (Parent (Parent (T))) = + N_Subtype_Declaration))) + then + Error_Msg_N ("invalid use of type before its full declaration", T); + end if; + end Check_Incomplete; - -- Is_Tagged indicates whether the type is tagged. It is tagged if - -- it's "is new ... with record" or else "is tagged record ...". + -- Start of processing for Process_Subtype - 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 + -- Case of no constraints present - 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 Nkind (S) /= N_Subtype_Indication then + Find_Type (S); + Check_Incomplete (S); + P := Parent (S); - 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; + -- Ada 2005 (AI-231): Static check + + if Ada_Version >= Ada_2005 + and then Present (P) + and then Null_Exclusion_Present (P) + and then Nkind (P) /= N_Access_To_Object_Definition + and then not Is_Access_Type (Entity (S)) + then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + end if; - return; + -- The following is ugly, can't we have a range or even a flag??? - elsif Has_Private_Declaration (Typ) then + May_Have_Null_Exclusion := + Nkind_In (P, N_Access_Definition, + N_Access_Function_Definition, + N_Access_Procedure_Definition, + N_Access_To_Object_Definition, + N_Allocator, + N_Component_Definition) + or else + Nkind_In (P, N_Derived_Type_Definition, + N_Discriminant_Specification, + N_Formal_Object_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Parameter_Specification, + N_Subtype_Declaration); - -- 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. + -- Create an Itype that is a duplicate of Entity (S) but with the + -- null-exclusion attribute. - if Is_Tagged then - Make_Class_Wide_Type (Typ); - end if; + if May_Have_Null_Exclusion + and then Is_Access_Type (Entity (S)) + and then Null_Exclusion_Present (P) - return; + -- No need to check the case of an access to object definition. + -- It is correct to define double not-null pointers. - -- If there was a previous anonymous access type, the incomplete - -- type declaration will have been created already. + -- Example: + -- type Not_Null_Int_Ptr is not null access Integer; + -- type Acc is not null access Not_Null_Int_Ptr; - elsif Present (Current_Entity (Typ)) - and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type - and then Full_View (Current_Entity (Typ)) = Typ + and then Nkind (P) /= N_Access_To_Object_Definition 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; + if Can_Never_Be_Null (Entity (S)) then + case Nkind (Related_Nod) is + when N_Full_Type_Declaration => + if Nkind (Type_Definition (Related_Nod)) + in N_Array_Type_Definition + then + Error_Node := + Subtype_Indication + (Component_Definition + (Type_Definition (Related_Nod))); + else + Error_Node := + Subtype_Indication (Type_Definition (Related_Nod)); + end if; - else - Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); - Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + when N_Subtype_Declaration => + Error_Node := Subtype_Indication (Related_Nod); - -- 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. + when N_Object_Declaration => + Error_Node := Object_Definition (Related_Nod); - H := Current_Entity (Typ); + when N_Component_Declaration => + Error_Node := + Subtype_Indication (Component_Definition (Related_Nod)); - 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; + when N_Allocator => + Error_Node := Expression (Related_Nod); - Set_Homonym (H, Homonym (Typ)); + when others => + pragma Assert (False); + Error_Node := Related_Nod; + end case; + + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); end if; - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); - Set_Full_View (Inc_T, Typ); + Set_Etype (S, + Create_Null_Excluding_Itype + (T => Entity (S), + Related_Nod => P)); + Set_Entity (S, Etype (S)); + end if; - if Is_Tagged then + return Entity (S); - -- Create a common class-wide type for both views, and set the - -- Etype of the class-wide type to the full view. + -- Case of constraint present, so that we have an N_Subtype_Indication + -- node (this node is created only if constraints are present). - 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; + else + Find_Type (Subtype_Mark (S)); + + if Nkind (Parent (S)) /= N_Access_To_Object_Definition + and then not + (Nkind (Parent (S)) = N_Subtype_Declaration + and then Is_Itype (Defining_Identifier (Parent (S)))) + then + Check_Incomplete (Subtype_Mark (S)); end if; - end Build_Incomplete_Type_Declaration; - ------------------ - -- Designates_T -- - ------------------ + P := Parent (S); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); - function Designates_T (Subt : Node_Id) return Boolean is - Type_Id : constant Name_Id := Chars (Typ); + -- Explicit subtype declaration case - 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. + if Nkind (P) = N_Subtype_Declaration then + Def_Id := Defining_Identifier (P); - ------------- - -- Names_T -- - ------------- + -- Explicit derived type definition case - function Names_T (Nam : Node_Id) return Boolean is - begin - if Nkind (Nam) = N_Identifier then - return Chars (Nam) = Type_Id; + elsif Nkind (P) = N_Derived_Type_Definition then + Def_Id := Defining_Identifier (Parent (P)); - 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); + -- Implicit case, the Def_Id must be created as an implicit type. + -- The one exception arises in the case of concurrent types, array + -- and access types, where other subsidiary implicit types may be + -- created and must appear before the main implicit type. In these + -- cases we leave Def_Id set to Empty as a signal that Create_Itype + -- has not yet been called to create Def_Id. - elsif Nkind (Prefix (Nam)) = N_Selected_Component then - return Chars (Selector_Name (Prefix (Nam))) = - Chars (Current_Scope); - else - return False; - end if; + else + if Is_Array_Type (Subtype_Mark_Id) + or else Is_Concurrent_Type (Subtype_Mark_Id) + or else Is_Access_Type (Subtype_Mark_Id) + then + Def_Id := Empty; - else - return False; - end if; + -- For the other cases, we create a new unattached Itype, + -- and set the indication to ensure it gets attached later. else - return False; + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); end if; - end Names_T; - - -- Start of processing for Designates_T + end if; - begin - if Nkind (Subt) = N_Identifier then - return Chars (Subt) = Type_Id; + -- If the kind of constraint is invalid for this kind of type, + -- then give an error, and then pretend no constraint was given. - -- Reference can be through an expanded name which has not been - -- analyzed yet, and which designates enclosing scopes. + if not Is_Valid_Constraint_Kind + (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); - elsif Nkind (Subt) = N_Selected_Component then - if Names_T (Subt) then - return True; + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); - -- 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. + -- Set Ekind of orphan itype, to prevent cascaded errors - 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)); + if Present (Def_Id) then + Set_Ekind (Def_Id, Ekind (Any_Type)); 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)); + -- Make recursive call, having got rid of the bogus constraint - else - return False; + return Process_Subtype (S, Related_Nod, Related_Id, Suffix); end if; - end Designates_T; - ---------------- - -- Mentions_T -- - ---------------- + -- Remaining processing depends on type. Select on Base_Type kind to + -- ensure getting to the concrete type kind in the case of a private + -- subtype (needed when only doing semantic analysis). + + case Ekind (Base_Type (Subtype_Mark_Id)) is + when Access_Kind => + + -- If this is a constraint on a class-wide type, discard it. + -- There is currently no way to express a partial discriminant + -- constraint on a type with unknown discriminants. This is + -- a pathology that the ACATS wisely decides not to test. + + if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then + if Comes_From_Source (S) then + Error_Msg_N + ("constraint on class-wide type ignored??", + Constraint (S)); + end if; - function Mentions_T (Acc_Def : Node_Id) return Boolean is - Param_Spec : Node_Id; + if Nkind (P) = N_Subtype_Declaration then + Set_Subtype_Indication (P, + New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); + end if; - Acc_Subprg : constant Node_Id := - Access_To_Subprogram_Definition (Acc_Def); + return Subtype_Mark_Id; + end if; - begin - if No (Acc_Subprg) then - return Designates_T (Subtype_Mark (Acc_Def)); - end if; + Constrain_Access (Def_Id, S, Related_Nod); - -- Component is an access_to_subprogram: examine its formals, - -- and result definition in the case of an access_to_function. + if Expander_Active + and then Is_Itype (Designated_Type (Def_Id)) + and then Nkind (Related_Nod) = N_Subtype_Declaration + and then not Is_Incomplete_Type (Designated_Type (Def_Id)) + then + Build_Itype_Reference + (Designated_Type (Def_Id), Related_Nod); + end if; - 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; + when Array_Kind => + Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); - elsif Designates_T (Parameter_Type (Param_Spec)) then - return True; - end if; + when Decimal_Fixed_Point_Kind => + Constrain_Decimal (Def_Id, S); - Next (Param_Spec); - end loop; + when Enumeration_Kind => + Constrain_Enumeration (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); - 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; + when Ordinary_Fixed_Point_Kind => + Constrain_Ordinary_Fixed (Def_Id, S); - return False; - end Mentions_T; + when Float_Kind => + Constrain_Float (Def_Id, S); - -- Start of processing for Check_Anonymous_Access_Components + when Integer_Kind => + Constrain_Integer (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); - begin - if No (Comp_List) then - return; - end if; + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); - 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)); + if Ekind (Def_Id) = E_Incomplete_Type then + Set_Private_Dependents (Def_Id, New_Elmt_List); + end if; - Build_Incomplete_Type_Declaration; - Anon_Access := Make_Temporary (Loc, 'S'); + when Private_Kind => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + Set_Private_Dependents (Def_Id, New_Elmt_List); - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. + -- In case of an invalid constraint prevent further processing + -- since the type constructed is missing expected fields. - 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)); + if Etype (Def_Id) = Any_Type then + return Def_Id; end if; - else - Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - Relocate_Node - (Subtype_Mark - (Access_Definition (Comp_Def)))); + -- If the full view is that of a task with discriminants, + -- we must constrain both the concurrent type and its + -- corresponding record type. Otherwise we will just propagate + -- the constraint to the full view, if available. - Set_Constant_Present - (Type_Def, Constant_Present (Access_Definition (Comp_Def))); - Set_All_Present - (Type_Def, All_Present (Access_Definition (Comp_Def))); - end if; + if Present (Full_View (Subtype_Mark_Id)) + and then Has_Discriminants (Subtype_Mark_Id) + and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) + then + Full_View_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - Set_Null_Exclusion_Present - (Type_Def, - Null_Exclusion_Present (Access_Definition (Comp_Def))); + Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); + Constrain_Concurrent (Full_View_Id, S, + Related_Nod, Related_Id, Suffix); + Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); + Set_Full_View (Def_Id, Full_View_Id); - Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + -- Introduce an explicit reference to the private subtype, + -- to prevent scope anomalies in gigi if first use appears + -- in a nested context, e.g. a later function body. + -- Should this be generated in other contexts than a full + -- type declaration? - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); + if Is_Itype (Def_Id) + and then + Nkind (Parent (P)) = N_Full_Type_Declaration + then + Build_Itype_Reference (Def_Id, Parent (P)); + end if; - -- If an access to subprogram, create the extra formals + else + Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); + end if; - if Present (Acc_Def) then - Create_Extra_Formals (Designated_Type (Anon_Access)); + when Concurrent_Kind => + Constrain_Concurrent (Def_Id, S, + Related_Nod, Related_Id, Suffix); - -- If an access to object, preserve entity of designated type, - -- for ASIS use, before rewriting the component definition. + when others => + Error_Msg_N ("invalid subtype mark in subtype indication", S); + end case; - else - declare - Desig : Entity_Id; + -- Size and Convention are always inherited from the base type - begin - Desig := Entity (Subtype_Indication (Type_Def)); + Set_Size_Info (Def_Id, (Subtype_Mark_Id)); + Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); - -- 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 + return Def_Id; + end if; + end Process_Subtype; - if Ekind (Desig) = E_Incomplete_Type then - Desig := Full_View (Desig); - end if; + -------------------------------------------- + -- Propagate_Default_Init_Cond_Attributes -- + -------------------------------------------- - Set_Entity - (Subtype_Mark (Access_Definition (Comp_Def)), Desig); - end; - end if; + 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 + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id); + -- Remove the default initial procedure (if any) from the rep chain of + -- type Typ. - Rewrite (Comp_Def, - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); + ---------------------------------------- + -- Remove_Default_Init_Cond_Procedure -- + ---------------------------------------- - 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; + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is + Found : Boolean := False; + Prev : Entity_Id; + Subp : Entity_Id; - Set_Is_Local_Anonymous_Access (Anon_Access); - end if; + begin + Prev := Typ; + Subp := Subprograms_For_Type (Typ); + while Present (Subp) loop + if Is_Default_Init_Cond_Procedure (Subp) then + Found := True; + exit; + end if; - Next (Comp); - end loop; + Prev := Subp; + Subp := Subprograms_For_Type (Subp); + 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; + if Found then + Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp)); + Set_Subprograms_For_Type (Subp, Empty); + end if; + end Remove_Default_Init_Cond_Procedure; - ---------------------------------- - -- Preanalyze_Assert_Expression -- - ---------------------------------- + -- Local variables - 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; + Inherit_Procedure : Boolean := False; - ----------------------------------- - -- Preanalyze_Default_Expression -- - ----------------------------------- + -- Start of processing for Propagate_Default_Init_Cond_Attributes - 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 -- - -------------------------------- + -- A full view inherits the attributes from its private view + + if Has_Default_Init_Cond (From_Typ) then + Set_Has_Default_Init_Cond (To_Typ); + Inherit_Procedure := True; + + -- 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. + + -- 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 + -- with Default_Initial_Condition ...; + -- private + -- type Deriv_Typ is new Parent_Typ; + -- end Pack_2; + + -- 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. + + if Private_To_Full_View then + Set_Has_Inherited_Default_Init_Cond (To_Typ, False); + Remove_Default_Init_Cond_Procedure (To_Typ); + end if; + + -- 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. + + 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; - 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; + 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 Propagate_Default_Init_Cond_Attributes; ----------------------------- -- Record_Type_Declaration -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 85105e538e0..a5c77fc7f23 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1247,7 +1247,7 @@ package body Sem_Util is 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 @@ package body Sem_Util is 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")); -- 2.30.2