-- 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;
-- 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
(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.
-- (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);
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);
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);
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));
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;
declare
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (N));
-
begin
if Nkind (Sindic) = N_Subtype_Indication
and then Present (Constraint (Sindic))
-- (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;
-- 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);
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;
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.
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);
-- 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
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;
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);
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;
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",
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;
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);
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);
-- 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
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)
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
-- 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
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
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;
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 :=
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,
else
Error_Msg_N
- ("initialization of limited object requires agggregate "
+ ("initialization of limited object requires aggregate "
& "or function call", Exp);
end if;
end if;
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
------------------------
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;
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);
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;
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)
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;
--------------------------------
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);
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))
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
-- 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;
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
-- 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);
-- secondary tags of the parent.
if Ekind (Component) = E_Component
- and then Present (Related_Interface (Component))
+ and then Present (Related_Type (Component))
then
null;
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 |
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;
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;
-- Case of no constraints present
if Nkind (S) /= N_Subtype_Indication then
-
Find_Type (S);
Check_Incomplete (S);
P := Parent (S);
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
------------------
function Designates_T (Subt : Node_Id) return Boolean is
-
Type_Id : constant Name_Id := Chars (Typ);
function Names_T (Nam : Node_Id) return Boolean;
else
return False;
end if;
+
else
return False;
end if;
+
else
return False;
end if;
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
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
end if;
return False;
-
end Mentions_T;
-- Start of processing for Check_Anonymous_Access_Components
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);
projects / platform / upstream / linaro-gcc.git / commitdiff