diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 311 |
1 files changed, 262 insertions, 49 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b96b9d9ba38..adea69db29e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -753,6 +753,7 @@ package body Sem_Ch3 is -- is associated with one of the protected operations, and must -- be available in the scope that encloses the protected declaration. -- Otherwise the type is in the scope enclosing the subprogram. + -- If the function has formals, The return type of a subprogram -- declaration is analyzed in the scope of the subprogram (see -- Process_Formals) and thus the protected type, if present, is @@ -1506,6 +1507,96 @@ package body Sem_Ch3 is end if; end Add_Interface_Tag_Components; + ------------------------------------- + -- Add_Internal_Interface_Entities -- + ------------------------------------- + + procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + + begin + pragma Assert (Ada_Version >= Ada_05 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type) + and then not Is_Interface (Tagged_Type)); + + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + -- Exclude from this processing interfaces that are parents of + -- Tagged_Type because their primitives are located in the primary + -- dispatch table (and hence no auxiliary internal entities are + -- required to handle secondary dispatch tables in such case). + + if not Is_Ancestor (Iface, Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + pragma Assert (Present (Prim)); + + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the tagged + -- type. They are only used to fill the contents of the + -- secondary dispatch tables. Therefore they are not needed + -- in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have set + -- the Has_Delay_Freeze attribute to ensure that, in case of + -- locally defined tagged types (or compiling with static + -- dispatch tables generation disabled) the corresponding + -- entry of the secondary dispatch table is filled when + -- such an entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + end Add_Internal_Interface_Entities; + ----------------------------------- -- Analyze_Component_Declaration -- ----------------------------------- @@ -2588,8 +2679,8 @@ package body Sem_Ch3 is and then Is_Access_Constant (Etype (E)) then Error_Msg_N - ("access to variable cannot be initialized " & - "with an access-to-constant expression", E); + ("access to variable cannot be initialized " + & "with an access-to-constant expression", E); end if; if not Assignment_OK (N) then @@ -2598,10 +2689,9 @@ package body Sem_Ch3 is Check_Unset_Reference (E); - -- If this is a variable, then set current value. - -- If this is a declared constant of a scalar type - -- with a static expression, indicate that it is - -- always valid. + -- If this is a variable, then set current value. If this is a + -- declared constant of a scalar type with a static expression, + -- indicate that it is always valid. if not Constant_Present (N) then if Compile_Time_Known_Value (E) then @@ -4827,17 +4917,74 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - D_Constraint : Node_Id; - Disc_Spec : Node_Id; - Old_Disc : Entity_Id; - New_Disc : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + + Corr_Record : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + + Corr_Decl : Node_Id; + Corr_Decl_Needed : Boolean; + -- If the derived type has fewer discriminants than its parent, the + -- corresponding record is also a derived type, in order to account for + -- the bound discriminants. We create a full type declaration for it in + -- this case. Constraint_Present : constant Boolean := - Nkind (Subtype_Indication (Type_Definition (N))) - = N_Subtype_Indication; + Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication; + + D_Constraint : Node_Id; + New_Constraint : Elist_Id; + Old_Disc : Entity_Id; + New_Disc : Entity_Id; + New_N : Node_Id; begin Set_Stored_Constraint (Derived_Type, No_Elist); + Corr_Decl_Needed := False; + Old_Disc := Empty; + + if Present (Discriminant_Specifications (N)) + and then Constraint_Present + then + Old_Disc := First_Discriminant (Parent_Type); + New_Disc := First (Discriminant_Specifications (N)); + while Present (New_Disc) and then Present (Old_Disc) loop + Next_Discriminant (Old_Disc); + Next (New_Disc); + end loop; + end if; + + if Present (Old_Disc) then + + -- The new type has fewer discriminants, so we need to create a new + -- corresponding record, which is derived from the corresponding + -- record of the parent, and has a stored constraint that captures + -- the values of the discriminant constraints. + + -- The type declaration for the derived corresponding record has + -- the same discriminant part and constraints as the current + -- declaration. Copy the unanalyzed tree to build declaration. + + Corr_Decl_Needed := True; + New_N := Copy_Separate_Tree (N); + + Corr_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Corr_Record, + Discriminant_Specifications => + Discriminant_Specifications (New_N), + Type_Definition => + Make_Derived_Type_Definition (Loc, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (Corresponding_Record_Type (Parent_Type), Loc), + Constraint => + Constraint + (Subtype_Indication (Type_Definition (New_N)))))); + end if; -- Copy Storage_Size and Relative_Deadline variables if task case @@ -4851,6 +4998,16 @@ package body Sem_Ch3 is if Present (Discriminant_Specifications (N)) then Push_Scope (Derived_Type); Check_Or_Process_Discriminants (N, Derived_Type); + + if Constraint_Present then + New_Constraint := + Expand_To_Stored_Constraint + (Parent_Type, + Build_Discriminant_Constraints + (Parent_Type, + Subtype_Indication (Type_Definition (N)), True)); + end if; + End_Scope; elsif Constraint_Present then @@ -4881,9 +5038,9 @@ package body Sem_Ch3 is end; end if; - -- All attributes are inherited from parent. In particular, - -- entries and the corresponding record type are the same. - -- Discriminants may be renamed, and must be treated separately. + -- By default, operations and private data are inherited from parent. + -- However, in the presence of bound discriminants, a new corresponding + -- record will be created, see below. Set_Has_Discriminants (Derived_Type, Has_Discriminants (Parent_Type)); @@ -4911,61 +5068,110 @@ package body Sem_Ch3 is (Constraints (Constraint (Subtype_Indication (Type_Definition (N))))); - Old_Disc := First_Discriminant (Parent_Type); - New_Disc := First_Discriminant (Derived_Type); - Disc_Spec := First (Discriminant_Specifications (N)); - while Present (Old_Disc) and then Present (Disc_Spec) loop - if Nkind (Discriminant_Type (Disc_Spec)) /= - N_Access_Definition - then - Analyze (Discriminant_Type (Disc_Spec)); + Old_Disc := First_Discriminant (Parent_Type); - if not Subtypes_Statically_Compatible ( - Etype (Discriminant_Type (Disc_Spec)), - Etype (Old_Disc)) - then - Error_Msg_N - ("not statically compatible with parent discriminant", - Discriminant_Type (Disc_Spec)); + while Present (D_Constraint) loop + if Nkind (D_Constraint) /= N_Discriminant_Association then + + -- Positional constraint. If it is a reference to a new + -- discriminant, it constrains the corresponding old one. + + if Nkind (D_Constraint) = N_Identifier then + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when Chars (New_Disc) = Chars (D_Constraint); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + Set_Corresponding_Discriminant (New_Disc, Old_Disc); + end if; + end if; + + Next_Discriminant (Old_Disc); + + -- if this is a named constraint, search by name for the old + -- discriminants constrained by the new one. + + elsif Nkind (Expression (D_Constraint)) = N_Identifier then + + -- Find new discriminant with that name + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + exit when + Chars (New_Disc) = Chars (Expression (D_Constraint)); + Next_Discriminant (New_Disc); + end loop; + + if Present (New_Disc) then + + -- Verify that new discriminant renames some discriminant + -- of the parent type, and associate the new discriminant + -- with one or more old ones that it renames. + + declare + Selector : Node_Id; + + begin + Selector := First (Selector_Names (D_Constraint)); + while Present (Selector) loop + Old_Disc := First_Discriminant (Parent_Type); + while Present (Old_Disc) loop + exit when Chars (Old_Disc) = Chars (Selector); + Next_Discriminant (Old_Disc); + end loop; + + if Present (Old_Disc) then + Set_Corresponding_Discriminant + (New_Disc, Old_Disc); + end if; + + Next (Selector); + end loop; + end; end if; end if; - if Nkind (D_Constraint) = N_Identifier - and then Chars (D_Constraint) /= - Chars (Defining_Identifier (Disc_Spec)) + Next (D_Constraint); + end loop; + + New_Disc := First_Discriminant (Derived_Type); + while Present (New_Disc) loop + if No (Corresponding_Discriminant (New_Disc)) then + Error_Msg_NE + ("new discriminant& must constrain old one", N, New_Disc); + + elsif not + Subtypes_Statically_Compatible + (Etype (New_Disc), + Etype (Corresponding_Discriminant (New_Disc))) then - Error_Msg_N ("new discriminants must constrain old ones", - D_Constraint); - else - Set_Corresponding_Discriminant (New_Disc, Old_Disc); + Error_Msg_NE + ("& not statically compatible with parent discriminant", + N, New_Disc); end if; - Next_Discriminant (Old_Disc); Next_Discriminant (New_Disc); - Next (Disc_Spec); end loop; - - if Present (Old_Disc) or else Present (Disc_Spec) then - Error_Msg_N ("discriminant mismatch in derivation", N); - end if; - end if; elsif Present (Discriminant_Specifications (N)) then Error_Msg_N - ("missing discriminant constraint in untagged derivation", - N); + ("missing discriminant constraint in untagged derivation", N); end if; + -- The entity chain of the derived type includes the new discriminants + -- but shares operations with the parent. + if Present (Discriminant_Specifications (N)) then Old_Disc := First_Discriminant (Parent_Type); while Present (Old_Disc) loop - if No (Next_Entity (Old_Disc)) or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant then - Set_Next_Entity (Last_Entity (Derived_Type), - Next_Entity (Old_Disc)); + Set_Next_Entity + (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); exit; end if; @@ -4984,6 +5190,13 @@ package body Sem_Ch3 is Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); Set_Has_Completion (Derived_Type); + + if Corr_Decl_Needed then + Set_Stored_Constraint (Derived_Type, New_Constraint); + Insert_After (N, Corr_Decl); + Analyze (Corr_Decl); + Set_Corresponding_Record_Type (Derived_Type, Corr_Record); + end if; end Build_Derived_Concurrent_Type; ------------------------------------ |