diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 429 |
1 files changed, 241 insertions, 188 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7110231..3be25a1 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -729,8 +729,8 @@ package body Sem_Ch3 is -- function, scope is the current one, because it is the one of the -- current type declaration. - if Nkind (Related_Nod) = N_Object_Declaration - or else Nkind (Related_Nod) = N_Access_Function_Definition + if Nkind_In (Related_Nod, N_Object_Declaration, + N_Access_Function_Definition) then Anon_Scope := Current_Scope; @@ -743,7 +743,7 @@ package body Sem_Ch3 is -- unit, we must traverse the the tree to retrieve the proper entity. elsif Nkind (Related_Nod) = N_Function_Specification - and then Nkind (Parent (N)) /= N_Parameter_Specification + and then Nkind (Parent (N)) /= N_Parameter_Specification then -- If the current scope is a protected type, the anonymous access -- is associated with one of the protected operations, and must @@ -789,6 +789,9 @@ package body Sem_Ch3 is (Anon_Type, E_Anonymous_Access_Subprogram_Type); end if; + Set_Can_Use_Internal_Rep + (Anon_Type, not Always_Compatible_Rep_On_Target); + -- If the anonymous access is associated with a protected operation -- create a reference to it after the enclosing protected definition -- because the itype will be used in the subsequent bodies. @@ -932,16 +935,17 @@ package body Sem_Ch3 is -- (Z : access T))) D_Ityp := Associated_Node_For_Itype (Desig_Type); - while Nkind (D_Ityp) /= N_Full_Type_Declaration - and then Nkind (D_Ityp) /= N_Private_Type_Declaration - and then Nkind (D_Ityp) /= N_Private_Extension_Declaration - and then Nkind (D_Ityp) /= N_Procedure_Specification - and then Nkind (D_Ityp) /= N_Function_Specification - and then Nkind (D_Ityp) /= N_Object_Declaration - and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration - and then Nkind (D_Ityp) /= N_Formal_Type_Declaration - and then Nkind (D_Ityp) /= N_Task_Type_Declaration - and then Nkind (D_Ityp) /= N_Protected_Type_Declaration + while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, + N_Private_Type_Declaration, + N_Private_Extension_Declaration, + N_Procedure_Specification, + N_Function_Specification) + or else + Nkind_In (D_Ityp, N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Formal_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration)) loop D_Ityp := Parent (D_Ityp); pragma Assert (D_Ityp /= Empty); @@ -949,22 +953,21 @@ package body Sem_Ch3 is Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); - if Nkind (D_Ityp) = N_Procedure_Specification - or else Nkind (D_Ityp) = N_Function_Specification + if Nkind_In (D_Ityp, N_Procedure_Specification, + N_Function_Specification) then Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); - elsif Nkind (D_Ityp) = N_Full_Type_Declaration - or else Nkind (D_Ityp) = N_Object_Declaration - or else Nkind (D_Ityp) = N_Object_Renaming_Declaration - or else Nkind (D_Ityp) = N_Formal_Type_Declaration + elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Formal_Type_Declaration) then Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); end if; if Nkind (T_Def) = N_Access_Function_Definition then if Nkind (Result_Definition (T_Def)) = N_Access_Definition then - declare Acc : constant Node_Id := Result_Definition (T_Def); @@ -1057,6 +1060,8 @@ package body Sem_Ch3 is Set_Ekind (T_Name, E_Access_Subprogram_Type); end if; + Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target); + Set_Etype (T_Name, T_Name); Init_Size_Align (T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); @@ -1229,7 +1234,7 @@ package body Sem_Ch3 is Set_Ekind (Tag, E_Component); Set_Is_Tag (Tag); Set_Is_Aliased (Tag); - Set_Related_Interface (Tag, Iface); + Set_Related_Type (Tag, Iface); Init_Component_Location (Tag); pragma Assert (Is_Frozen (Iface)); @@ -1271,7 +1276,7 @@ package body Sem_Ch3 is Set_Analyzed (Decl); Set_Ekind (Offset, E_Component); Set_Is_Aliased (Offset); - Set_Related_Interface (Offset, Iface); + Set_Related_Type (Offset, Iface); Init_Component_Location (Offset); Insert_After (Last_Tag, Decl); Last_Tag := Decl; @@ -1620,7 +1625,6 @@ package body Sem_Ch3 is declare Sindic : constant Node_Id := Subtype_Indication (Component_Definition (N)); - begin if Nkind (Sindic) = N_Subtype_Indication and then Present (Constraint (Sindic)) @@ -1764,9 +1768,9 @@ package body Sem_Ch3 is -- (This is needed in any case for early instantiations ???). if No (Next_Node) then - if Nkind (Parent (L)) = N_Component_List - or else Nkind (Parent (L)) = N_Task_Definition - or else Nkind (Parent (L)) = N_Protected_Definition + if Nkind_In (Parent (L), N_Component_List, + N_Task_Definition, + N_Protected_Definition) then null; @@ -1810,12 +1814,13 @@ package body Sem_Ch3 is -- not cause unwanted freezing at that point. elsif not Analyzed (Next_Node) - and then (Nkind (Next_Node) = N_Subprogram_Body - or else Nkind (Next_Node) = N_Entry_Body - or else Nkind (Next_Node) = N_Package_Body - or else Nkind (Next_Node) = N_Protected_Body - or else Nkind (Next_Node) = N_Task_Body - or else Nkind (Next_Node) in N_Body_Stub) + and then (Nkind_In (Next_Node, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) + or else + Nkind (Next_Node) in N_Body_Stub) then Adjust_D; Freeze_All (Freeze_From, D); @@ -2070,9 +2075,7 @@ package body Sem_Ch3 is return; end if; - if Nkind (E) = N_Integer_Literal - or else Nkind (E) = N_Real_Literal - then + if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then Set_Etype (E, Etype (Id)); end if; @@ -2364,20 +2367,6 @@ package body Sem_Ch3 is Set_Is_True_Constant (Id, True); - -- If the initialization expression is an access to constant, - -- it cannot be used with an access type. - - if Is_Access_Type (Etype (E)) - and then Is_Access_Constant (Etype (E)) - and then Is_Access_Type (T) - and then not Is_Access_Constant (T) - then - Error_Msg_NE ("object of type& cannot be initialized with " & - "an access-to-constant expression", - E, - T); - end if; - -- If we are analyzing a constant declaration, set its completion -- flag after analyzing the expression. @@ -3277,6 +3266,8 @@ package body Sem_Ch3 is Set_Is_Limited_Record (Id, Is_Limited_Record (T)); Set_Has_Unknown_Discriminants (Id, Has_Unknown_Discriminants (T)); + Set_Known_To_Have_Preelab_Init + (Id, Known_To_Have_Preelab_Init (T)); if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); @@ -4307,9 +4298,7 @@ package body Sem_Ch3 is -- Temporarily remove the current scope from the stack to add the new -- declarations to the enclosing scope - if Nkind (N) = N_Object_Declaration - or else Nkind (N) = N_Access_Function_Definition - then + if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then Analyze (Decl); else @@ -4320,6 +4309,7 @@ package body Sem_Ch3 is end if; Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); + Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); return Anon; end Replace_Anonymous_Access_To_Protected_Subprogram; @@ -4635,7 +4625,7 @@ package body Sem_Ch3 is if Nkind (D_Constraint) = N_Identifier and then Chars (D_Constraint) /= - Chars (Defining_Identifier (Disc_Spec)) + Chars (Defining_Identifier (Disc_Spec)) then Error_Msg_N ("new discriminants must constrain old ones", D_Constraint); @@ -4967,8 +4957,11 @@ package body Sem_Ch3 is Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); Set_Parent (Implicit_Base, Parent (Derived_Type)); - if Is_Discrete_Type (Parent_Base) or else - Is_Decimal_Fixed_Point_Type (Parent_Base) + -- Set RM Size for discrete type or decimal fixed-point type + -- Ordinary fixed-point is excluded, why??? + + if Is_Discrete_Type (Parent_Base) + or else Is_Decimal_Fixed_Point_Type (Parent_Base) then Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); end if; @@ -5314,8 +5307,8 @@ package body Sem_Ch3 is and then Has_Discriminants (Full_View (Parent_Type)) then if Has_Unknown_Discriminants (Parent_Type) - and then Nkind (Subtype_Indication (Type_Definition (N))) - = N_Subtype_Indication + and then Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication then Error_Msg_N ("cannot constrain type with unknown discriminants", @@ -5973,7 +5966,7 @@ package body Sem_Ch3 is Discriminant_Specs : constant Boolean := Present (Discriminant_Specifications (N)); Private_Extension : constant Boolean := - (Nkind (N) = N_Private_Extension_Declaration); + Nkind (N) = N_Private_Extension_Declaration; Constraint_Present : Boolean; Inherit_Discrims : Boolean := False; @@ -7393,14 +7386,24 @@ package body Sem_Ch3 is Set_Ekind (Def_Id, E_Record_Subtype); end if; + -- Inherit preelaboration flag from base, for types for which it + -- may have been set: records, private types, protected types. + + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); + elsif Ekind (T) = E_Task_Type then Set_Ekind (Def_Id, E_Task_Subtype); elsif Ekind (T) = E_Protected_Type then Set_Ekind (Def_Id, E_Protected_Subtype); + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); elsif Is_Private_Type (T) then Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + Set_Known_To_Have_Preelab_Init + (Def_Id, Known_To_Have_Preelab_Init (T)); elsif Is_Class_Wide_Type (T) then Set_Ekind (Def_Id, E_Class_Wide_Subtype); @@ -7529,9 +7532,7 @@ package body Sem_Ch3 is Analyze_And_Resolve (Bound, Base_Type (Par_T)); - if Nkind (Bound) = N_Integer_Literal - or else Nkind (Bound) = N_Real_Literal - then + if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then New_Bound := New_Copy (Bound); Set_Etype (New_Bound, Der_T); Set_Analyzed (New_Bound); @@ -7826,8 +7827,6 @@ package body Sem_Ch3 is -- overriding in Ada2005, but wrappers need to be built for them -- (see exp_ch3, Build_Controlling_Function_Wrappers). - -- Use elseif here and avoid above goto??? - if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) and then Ada_Version >= Ada_05 @@ -7835,15 +7834,15 @@ package body Sem_Ch3 is and then not Comes_From_Source (Subp) and then not Is_Abstract_Subprogram (Alias (Subp)) then - goto Next_Subp; - end if; + null; - if (Is_Abstract_Subprogram (Subp) + elsif (Is_Abstract_Subprogram (Subp) or else Requires_Overriding (Subp) - or else (Has_Controlling_Result (Subp) - and then Present (Alias_Subp) - and then not Comes_From_Source (Subp) - and then Sloc (Subp) = Sloc (First_Subtype (T)))) + or else + (Has_Controlling_Result (Subp) + and then Present (Alias_Subp) + and then not Comes_From_Source (Subp) + and then Sloc (Subp) = Sloc (First_Subtype (T)))) and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) @@ -7851,6 +7850,7 @@ package body Sem_Ch3 is and then Chars (Subp) /= Name_uDisp_Asynchronous_Select and then Chars (Subp) /= Name_uDisp_Conditional_Select and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind + and then Chars (Subp) /= Name_uDisp_Requeue and then Chars (Subp) /= Name_uDisp_Timed_Select -- Ada 2005 (AI-251): Do not consider hidden entities associated @@ -7877,6 +7877,7 @@ package body Sem_Ch3 is -- Exp_Ch3.Make_Controlling_Wrapper_Functions). Type_Def := Type_Definition (Parent (T)); + if Nkind (Type_Def) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Type_Def)) and then @@ -7888,32 +7889,46 @@ package body Sem_Ch3 is or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then - Error_Msg_NE - ("type must be declared abstract or & overridden", - T, Subp); + -- The body of predefined primitives of tagged types derived + -- from interface types are generated later by Freeze_Type. - -- Traverse the whole chain of aliased subprograms to - -- complete the error notification. This is especially - -- useful for traceability of the chain of entities when the - -- subprogram corresponds with an interface subprogram - -- (which might be defined in another package) + if Is_Predefined_Dispatching_Operation (Subp) + and then Is_Abstract_Subprogram (Alias_Subp) + and then Is_Interface + (Root_Type (Find_Dispatching_Type (Subp))) + then + null; - if Present (Alias_Subp) then - declare - E : Entity_Id; + else + Error_Msg_NE + ("type must be declared abstract or & overridden", + T, Subp); - begin - E := Subp; - while Present (Alias (E)) loop - Error_Msg_Sloc := Sloc (E); - Error_Msg_NE ("\& has been inherited #", T, Subp); - E := Alias (E); - end loop; + -- Traverse the whole chain of aliased subprograms to + -- complete the error notification. This is especially + -- useful for traceability of the chain of entities when + -- the subprogram corresponds with an interface + -- subprogram (which may be defined in another package). + + if Present (Alias_Subp) then + declare + E : Entity_Id; + + begin + E := Subp; + while Present (Alias (E)) loop + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("\& has been inherited #", T, Subp); + E := Alias (E); + end loop; - Error_Msg_Sloc := Sloc (E); - Error_Msg_NE - ("\& has been inherited from subprogram #", T, Subp); - end; + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("\& has been inherited from subprogram #", + T, Subp); + end; + end if; end if; -- Ada 2005 (AI-345): Protected or task type implementing @@ -7960,8 +7975,36 @@ package body Sem_Ch3 is end if; end if; - <<Next_Subp>> - Next_Elmt (Elmt); + -- Ada 2005 (AI05-0030): Inspect hidden subprograms which provide + -- the mapping between interface and implementing type primitives. + -- If the interface alias is marked as Implemented_By_Entry, the + -- alias must be an entry wrapper. + + if Ada_Version >= Ada_05 + and then Is_Hidden (Subp) + and then Present (Abstract_Interface_Alias (Subp)) + and then Implemented_By_Entry (Abstract_Interface_Alias (Subp)) + and then Present (Alias_Subp) + and then + (not Is_Primitive_Wrapper (Alias_Subp) + or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry) + then + declare + Error_Ent : Entity_Id := T; + + begin + if Is_Concurrent_Record_Type (Error_Ent) then + Error_Ent := Corresponding_Concurrent_Type (Error_Ent); + end if; + + Error_Msg_Node_2 := Abstract_Interface_Alias (Subp); + Error_Msg_NE + ("type & must implement abstract subprogram & with an entry", + Error_Ent, Error_Ent); + end; + end if; + + Next_Elmt (Elmt); end loop; end Check_Abstract_Overriding; @@ -8125,8 +8168,8 @@ package body Sem_Ch3 is 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. + -- It may be that the completion is mistyped and appears as + -- a distinct overloading of the entity. declare Candidate : constant Entity_Id := @@ -8163,18 +8206,17 @@ package body Sem_Ch3 is if Is_Intrinsic_Subprogram (E) then null; - -- The following situation requires special handling: a child - -- unit that appears in the context clause of the body of its - -- parent: + -- The following situation requires special handling: a child unit + -- that appears in the context clause of the body of its parent: -- procedure Parent.Child (...); -- with Parent.Child; -- package body Parent is - -- Here Parent.Child appears as a local entity, but should not - -- be flagged as requiring completion, because it is a - -- compilation unit. + -- Here Parent.Child appears as a local entity, but should not be + -- flagged as requiring completion, because it is a compilation + -- unit. -- Ignore missing completion for a subprogram that does not come from -- source (including the _Call primitive operation of RAS types, @@ -8359,7 +8401,7 @@ package body Sem_Ch3 is else Error_Msg_N - ("initialization of limited object requires agggregate " + ("initialization of limited object requires aggregate " & "or function call", Exp); end if; end if; @@ -11086,10 +11128,10 @@ package body Sem_Ch3 is Next_Elmt (Elmt); end loop; - -- Complete the derivation of the interface subprograms. Assignate to - -- each entity associated with abstract interfaces their aliased entity - -- and complete their decoration as hidden interface entities that will - -- be used later to build the secondary dispatch tables. + -- Complete the derivation of the interface subprograms. Assign to each + -- entity associated with abstract interfaces their aliased entity and + -- complete their decoration as hidden interface entities that will be + -- used later to build the secondary dispatch tables. if not Is_Empty_Elmt_List (Ifaces_List) then if Ekind (Parent_Type) = E_Record_Type_With_Private @@ -11605,13 +11647,14 @@ package body Sem_Ch3 is ------------------------ procedure Derive_Subprograms - (Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Generic_Actual : Entity_Id := Empty) + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty) is Op_List : constant Elist_Id := Collect_Primitive_Operations (Parent_Type); Ifaces_List : constant Elist_Id := New_Elmt_List; + Predef_Prims : constant Elist_Id := New_Elmt_List; Act_List : Elist_Id; Act_Elmt : Elmt_Id; Elmt : Elmt_Id; @@ -11629,7 +11672,9 @@ package body Sem_Ch3 is Parent_Base := Parent_Type; end if; - -- Derive primitives inherited from the parent + -- 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. if Present (Generic_Actual) then Act_List := Collect_Primitive_Operations (Generic_Actual); @@ -11652,18 +11697,27 @@ package body Sem_Ch3 is then null; + -- We derive predefined primitives in a later round to ensure that + -- they are always added to the list of primitives after user + -- defined primitives (because predefined primitives have to be + -- skipped when matching the operations of a parent interface to + -- those of a concrete type). However it is unclear why those + -- primitives would be needed in an instantiation??? + + elsif Is_Predefined_Dispatching_Operation (Subp) then + Append_Elmt (Subp, Predef_Prims); + elsif No (Generic_Actual) then Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base); - -- Ada 2005 (AI-251): Add the derivation of an abstract - -- interface primitive to the list of entities to which - -- we have to associate an aliased entity. + -- Ada 2005 (AI-251): Add derivation of an abstract interface + -- primitive to the list of entities to which we have to + -- associate an aliased entity. if Ada_Version >= Ada_05 and then Is_Dispatching_Operation (Subp) and then Present (Find_Dispatching_Type (Subp)) and then Is_Interface (Find_Dispatching_Type (Subp)) - and then not Is_Predefined_Dispatching_Operation (Subp) then Append_Elmt (New_Subp, Ifaces_List); end if; @@ -11714,13 +11768,12 @@ package body Sem_Ch3 is Next_Elmt (Elmt); end loop; - -- Inherit additional operations from progenitor interfaces. - -- However, if the derived type is a generic actual, there - -- are not new primitive operations for the type, because - -- it has those of the actual, so 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. + -- Inherit additional operations from progenitor interfaces. However, + -- if the derived type is a generic actual, there are not new primitive + -- operations for the type, because it has those of the actual, so + -- 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. if Ada_Version >= Ada_05 and then Is_Tagged_Type (Derived_Type) @@ -11728,6 +11781,17 @@ package body Sem_Ch3 is then Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); end if; + + -- Derive predefined primitives + + if not Is_Empty_Elmt_List (Predef_Prims) then + Elmt := First_Elmt (Predef_Prims); + while Present (Elmt) loop + Derive_Subprogram + (New_Subp, Node (Elmt), Derived_Type, Parent_Base); + Next_Elmt (Elmt); + end loop; + end if; end Derive_Subprograms; -------------------------------- @@ -11795,12 +11859,12 @@ package body Sem_Ch3 is Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - -- 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 + -- 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. Freeze_Before (N, Implicit_Base); @@ -12495,9 +12559,9 @@ package body Sem_Ch3 is Enter_Name (Id); New_Id := Id; - elsif Nkind (N) /= N_Full_Type_Declaration - and then Nkind (N) /= N_Task_Type_Declaration - and then Nkind (N) /= N_Protected_Type_Declaration + elsif not Nkind_In (N, N_Full_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) then -- Completion must be a full type declarations (RM 7.3(4)) @@ -12542,17 +12606,15 @@ package body Sem_Ch3 is New_Id := Id; elsif Ekind (Prev) = E_Private_Type - and then - (Nkind (N) = N_Task_Type_Declaration - or else Nkind (N) = N_Protected_Type_Declaration) + 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); elsif Ekind (Prev) = E_Record_Type_With_Private - and then - (Nkind (N) = N_Task_Type_Declaration - or else Nkind (N) = N_Protected_Type_Declaration) + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) then if not Is_Limited_Record (Prev) then Error_Msg_N @@ -12569,8 +12631,8 @@ package body Sem_Ch3 is -- type or a protected type. This case arises when covering -- interface types. - elsif Nkind (N) = N_Task_Type_Declaration - or else Nkind (N) = N_Protected_Type_Declaration + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) then null; @@ -12643,8 +12705,8 @@ package body Sem_Ch3 is if Is_Type (Prev) and then (Is_Tagged_Type (Prev) or else Present (Class_Wide_Type (Prev))) - and then (Nkind (N) /= N_Task_Type_Declaration - and then Nkind (N) /= N_Protected_Type_Declaration) + and then not Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) then -- The full declaration is either a tagged record or an -- extension otherwise this is an error @@ -12706,8 +12768,8 @@ package body Sem_Ch3 is -- Case of an anonymous array subtype - if Def_Kind = N_Constrained_Array_Definition - or else Def_Kind = N_Unconstrained_Array_Definition + if Nkind_In (Def_Kind, N_Constrained_Array_Definition, + N_Unconstrained_Array_Definition) then T := Empty; Array_Type_Declaration (T, Obj_Def); @@ -13457,7 +13519,7 @@ package body Sem_Ch3 is -- secondary tags of the parent. if Ekind (Component) = E_Component - and then Present (Related_Interface (Component)) + and then Present (Related_Type (Component)) then null; @@ -13568,22 +13630,16 @@ package body Sem_Ch3 is return Constraint_Kind = N_Range_Constraint; when Decimal_Fixed_Point_Kind => - return - Constraint_Kind = N_Digits_Constraint - or else - Constraint_Kind = N_Range_Constraint; + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); when Ordinary_Fixed_Point_Kind => - return - Constraint_Kind = N_Delta_Constraint - or else - Constraint_Kind = N_Range_Constraint; + return Nkind_In (Constraint_Kind, N_Delta_Constraint, + N_Range_Constraint); when Float_Kind => - return - Constraint_Kind = N_Digits_Constraint - or else - Constraint_Kind = N_Range_Constraint; + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); when Access_Kind | Array_Kind | @@ -15520,19 +15576,14 @@ package body Sem_Ch3 is Type_Decl := Parent (R); while Present (Type_Decl) and then not - (Nkind (Type_Decl) = N_Full_Type_Declaration - or else - Nkind (Type_Decl) = N_Subtype_Declaration - or else - Nkind (Type_Decl) = N_Loop_Statement - or else - Nkind (Type_Decl) = N_Task_Type_Declaration - or else - Nkind (Type_Decl) = N_Single_Task_Declaration + (Nkind_In (Type_Decl, N_Full_Type_Declaration, + N_Subtype_Declaration, + N_Loop_Statement, + N_Task_Type_Declaration) or else - Nkind (Type_Decl) = N_Protected_Type_Declaration - or else - Nkind (Type_Decl) = N_Single_Protected_Declaration) + Nkind_In (Type_Decl, N_Single_Task_Declaration, + N_Protected_Type_Declaration, + N_Single_Protected_Declaration)) loop Type_Decl := Parent (Type_Decl); end loop; @@ -15550,8 +15601,8 @@ package body Sem_Ch3 is begin Indic := Parent (R); - while Present (Indic) and then not - (Nkind (Indic) = N_Subtype_Indication) + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication loop Indic := Parent (Indic); end loop; @@ -15694,7 +15745,6 @@ package body Sem_Ch3 is -- Case of no constraints present if Nkind (S) /= N_Subtype_Indication then - Find_Type (S); Check_Incomplete (S); P := Parent (S); @@ -15710,18 +15760,21 @@ package body Sem_Ch3 is Error_Msg_N ("`NOT NULL` only allowed for an access type", S); end if; + -- The following is ugly, can't we have a range or even a flag??? + May_Have_Null_Exclusion := - Nkind (P) = N_Access_Definition - or else Nkind (P) = N_Access_Function_Definition - or else Nkind (P) = N_Access_Procedure_Definition - or else Nkind (P) = N_Access_To_Object_Definition - or else Nkind (P) = N_Allocator - or else Nkind (P) = N_Component_Definition - or else Nkind (P) = N_Derived_Type_Definition - or else Nkind (P) = N_Discriminant_Specification - or else Nkind (P) = N_Object_Declaration - or else Nkind (P) = N_Parameter_Specification - or else Nkind (P) = N_Subtype_Declaration; + 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_Object_Declaration, + N_Parameter_Specification, + N_Subtype_Declaration); -- Create an Itype that is a duplicate of Entity (S) but with the -- null-exclusion attribute @@ -16079,7 +16132,6 @@ package body Sem_Ch3 is ------------------ function Designates_T (Subt : Node_Id) return Boolean is - Type_Id : constant Name_Id := Chars (Typ); function Names_T (Nam : Node_Id) return Boolean; @@ -16108,9 +16160,11 @@ package body Sem_Ch3 is else return False; end if; + else return False; end if; + else return False; end if; @@ -16143,8 +16197,8 @@ package body Sem_Ch3 is or else (Is_Class_Wide_Type (Entity (Subt)) and then - Chars (Etype (Base_Type (Entity (Subt)))) - = Type_Id)); + Chars (Etype (Base_Type (Entity (Subt)))) = + Type_Id)); end if; -- A reference to the current type may appear as the prefix of @@ -16168,7 +16222,7 @@ package body Sem_Ch3 is Param_Spec : Node_Id; Acc_Subprg : constant Node_Id := - Access_To_Subprogram_Definition (Acc_Def); + Access_To_Subprogram_Definition (Acc_Def); begin if No (Acc_Subprg) then @@ -16203,7 +16257,6 @@ package body Sem_Ch3 is end if; return False; - end Mentions_T; -- Start of processing for Check_Anonymous_Access_Components @@ -16445,9 +16498,9 @@ package body Sem_Ch3 is Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); Enter_Name (Tag_Comp); + Set_Ekind (Tag_Comp, E_Component); Set_Is_Tag (Tag_Comp); Set_Is_Aliased (Tag_Comp); - Set_Ekind (Tag_Comp, E_Component); Set_Etype (Tag_Comp, RTE (RE_Tag)); Set_DT_Entry_Count (Tag_Comp, No_Uint); Set_Original_Record_Component (Tag_Comp, Tag_Comp); |