with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
+with Exp_Atag; use Exp_Atag;
with Exp_Ch2; use Exp_Ch2;
with Exp_Ch9; use Exp_Ch9;
with Exp_Imgv; use Exp_Imgv;
-- Utility for array attributes, returns true on packed constrained
-- arrays, and on access to same.
+ function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
+ -- Returns true iff the given node refers to an attribute call that
+ -- can be expanded directly by the back end and does not need front end
+ -- expansion. Typically used for rounding and truncation attributes that
+ -- appear directly inside a conversion to integer.
+
----------------------------------
-- Compile_Stream_Body_In_Scope --
----------------------------------
-- Expand_Fpt_Attribute_RR --
-----------------------------
- -- The two arguments is converted to their root types to call the
+ -- The two arguments are converted to their root types to call the
-- appropriate runtime function, with the actual call being built
-- by Expand_Fpt_Attribute
when Attribute_Access =>
- if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then
+ if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
elsif Ekind (Btyp) = E_General_Access_Type then
Analyze_And_Resolve (N, Addr);
end;
+
+ -- Ada 2005 (AI-251): Class-wide interface objects are always
+ -- "displaced" to reference the tag associated with the interface
+ -- type. In order to obtain the real address of such objects we
+ -- generate a call to a run-time subprogram that returns the base
+ -- address of the object.
+
+ elsif Is_Class_Wide_Type (Etype (Pref))
+ and then Is_Interface (Etype (Pref))
+ then
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (N))));
+ Analyze (N);
+ return;
end if;
-- Deal with packed array reference, other cases are handled by gigi
-- operation _Alignment applied to X.
elsif Is_Class_Wide_Type (Ptyp) then
+
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already notified such violation.
+
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
+
New_Node :=
Make_Function_Call (Loc,
Name => New_Reference_To
-- not accurate (the procedure formal case), has been
-- handled above.
+ -- We use the Underlying_Type here (and below) in case the
+ -- type is private without discriminants, but the full type
+ -- has discriminants. This case is illegal, but we generate it
+ -- internally for passing to the Extra_Constrained parameter.
+
else
- Res := Is_Constrained (Etype (Ent));
+ Res := Is_Constrained (Underlying_Type (Etype (Ent)));
end if;
Rewrite (N,
(Nkind (Pref) = N_Explicit_Dereference
and then
not Has_Constrained_Partial_View (Base_Type (Typ)))
- or else Is_Constrained (Typ)),
+ or else Is_Constrained (Underlying_Type (Typ))),
Loc));
end if;
elsif Is_Class_Wide_Type (P_Type) then
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already notified such violation.
+
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
+
declare
Rtyp : constant Entity_Id := Root_Type (P_Type);
Dnn : Entity_Id;
-- Transforms 'Machine_Rounding into a call to the floating-point
-- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
- -- type).
+ -- type). Expansion is avoided for cases the back end can handle
+ -- directly.
when Attribute_Machine_Rounding =>
- Expand_Fpt_Attribute_R (N);
+ if not Is_Inline_Floating_Point_Attribute (N) then
+ Expand_Fpt_Attribute_R (N);
+ end if;
------------------
-- Machine_Size --
-- to the appropriate primitive Output function (RM 13.13.2(31)).
elsif Is_Class_Wide_Type (P_Type) then
+
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already notified such violation.
+
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
+
Tag_Write : declare
Strm : constant Node_Id := First (Exprs);
Item : constant Node_Id := Next (Strm);
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To
- (RTE (RE_Get_Access_Level), Loc),
- Parameter_Associations =>
- New_List (Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node (
- Duplicate_Subexpr (Item,
- Name_Req => True)),
- Attribute_Name =>
- Name_Tag))),
+ Build_Get_Access_Level (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (
+ Duplicate_Subexpr (Item,
+ Name_Req => True)),
+ Attribute_Name => Name_Tag)),
+
Right_Opnd =>
- Make_Integer_Literal
- (Loc, Type_Access_Level (P_Type))),
+ Make_Integer_Literal (Loc,
+ Type_Access_Level (P_Type))),
+
Then_Statements =>
New_List (Make_Raise_Statement (Loc,
New_Occurrence_Of (
elsif Is_Tagged_Type (U_Type) then
Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
--- -- All other record type cases, including protected records.
--- -- The latter only arise for expander generated code for
--- -- handling shared passive partition access.
+ -- All other record type cases, including protected records.
+ -- The latter only arise for expander generated code for
+ -- handling shared passive partition access.
else
pragma Assert
-- X'Size into a call to the primitive operation _Size applied to X.
elsif Is_Class_Wide_Type (Ptyp) then
+
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already notified such violation.
+
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
+
New_Node :=
Make_Function_Call (Loc,
Name => New_Reference_To
----------------
-- Transforms 'Truncation into a call to the floating-point attribute
- -- function Truncation in Fat_xxx (where xxx is the root type)
+ -- function Truncation in Fat_xxx (where xxx is the root type).
+ -- Expansion is avoided for cases the back end can handle directly.
when Attribute_Truncation =>
- Expand_Fpt_Attribute_R (N);
+ if not Is_Inline_Floating_Point_Attribute (N) then
+ Expand_Fpt_Attribute_R (N);
+ end if;
-----------------------
-- Unbiased_Rounding --
-- Transforms 'Unbiased_Rounding into a call to the floating-point
-- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
- -- root type)
+ -- root type). Expansion is avoided for cases the back end can handle
+ -- directly.
when Attribute_Unbiased_Rounding =>
- Expand_Fpt_Attribute_R (N);
+ if not Is_Inline_Floating_Point_Attribute (N) then
+ Expand_Fpt_Attribute_R (N);
+ end if;
----------------------
-- Unchecked_Access --
when Attribute_Unrestricted_Access =>
- if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then
+ if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
-- Ada 2005 (AI-251): If the designated type is an interface, then
-- to call the special routine Unaligned_Valid, which makes
-- the needed copy, being careful not to load the value into
-- any floating-point register. The argument in this case is
- -- obj'Address (see Unchecked_Valid routine in Fat_Gen).
+ -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
if Is_Possibly_Unaligned_Object (Pref) then
Set_Attribute_Name (N, Name_Unaligned_Valid);
-- Ada 2005 (AI-216): Program_Error is raised when executing
-- the default implementation of the Write attribute of an
- -- Unchecked_Union type.
+ -- Unchecked_Union type. However, if the 'Write reference is
+ -- within the generated Output stream procedure, Write outputs
+ -- the components, and the default values of the discriminant
+ -- are streamed by the Output procedure itself.
- if Is_Unchecked_Union (Base_Type (U_Type)) then
+ if Is_Unchecked_Union (Base_Type (U_Type))
+ and not Is_TSS (Current_Scope, TSS_Stream_Output)
+ then
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
and then Present (Packed_Array_Type (Arr));
end Is_Constrained_Packed_Array;
+ ----------------------------------------
+ -- Is_Inline_Floating_Point_Attribute --
+ ----------------------------------------
+
+ function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
+ Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
+
+ begin
+ if Nkind (Parent (N)) /= N_Type_Conversion
+ or else not Is_Integer_Type (Etype (Parent (N)))
+ then
+ return False;
+ end if;
+
+ -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
+ -- required back end support has not been implemented yet ???
+
+ return Id = Attribute_Truncation;
+ end Is_Inline_Floating_Point_Attribute;
+
end Exp_Attr;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
+with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
-- type, generate an accessibility check to verify that the level of
-- the type of the created object is not deeper than the level of the
-- access type. If the type of the qualified expression is class-
- -- wide, then always generate the check. Otherwise, only generate the
- -- check if the level of the qualified expression type is statically
- -- deeper than the access type. Although the static accessibility
- -- will generally have been performed as a legality check, it won't
- -- have been done in cases where the allocator appears in generic
- -- body, so a run-time check is needed in general.
+ -- wide, then always generate the check (except in the case where it
+ -- is known to be unnecessary, see comment below). Otherwise, only
+ -- generate the check if the level of the qualified expression type
+ -- is statically deeper than the access type. Although the static
+ -- accessibility will generally have been performed as a legality
+ -- check, it won't have been done in cases where the allocator
+ -- appears in generic body, so a run-time check is needed in general.
+ -- One special case is when the access type is declared in the same
+ -- scope as the class-wide allocator, in which case the check can
+ -- never fail, so it need not be generated. As an open issue, there
+ -- seem to be cases where the static level associated with the
+ -- class-wide object's underlying type is not sufficient to perform
+ -- the proper accessibility check, such as for allocators in nested
+ -- subprograms or accept statements initialized by class-wide formals
+ -- when the actual originates outside at a deeper static level. The
+ -- nested subprogram case might require passing accessibility levels
+ -- along with class-wide parameters, and the task case seems to be
+ -- an actual gap in the language rules that needs to be fixed by the
+ -- ARG. ???
if Ada_Version >= Ada_05
and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then
- (Is_Class_Wide_Type (Etype (Exp))
- or else
- Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT))
+ (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
+ or else
+ (Is_Class_Wide_Type (Etype (Exp))
+ and then Scope (PtrT) /= Current_Scope))
then
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Get_Access_Level), Loc),
- Parameter_Associations =>
- New_List (Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Temp, Loc),
- Attribute_Name =>
- Name_Tag))),
+ Build_Get_Access_Level (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Temp, Loc),
+ Attribute_Name => Name_Tag)),
Right_Opnd =>
- Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
+ Make_Integer_Literal (Loc,
+ Type_Access_Level (PtrT))),
Reason => PE_Accessibility_Check_Failed));
end if;
Temp : Entity_Id;
Node : Node_Id;
+ function Is_Local_Access_Discriminant (N : Node_Id) return Boolean;
+ -- If the allocator is for an access discriminant of a stack-allocated
+ -- object, the discriminant can be allocated locally as well, to ensure
+ -- that its lifetime does not exceed that of the enclosing object.
+ -- This is an optimization mandated / suggested by Ada 2005 AI-162.
+
+ ----------------------------------
+ -- Is_Local_Access_Discriminant --
+ ----------------------------------
+
+ function Is_Local_Access_Discriminant (N : Node_Id) return Boolean is
+ Decl : Node_Id;
+ Temp : Entity_Id;
+
+ begin
+ if Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint
+ and then not Is_Coextension (N)
+ and then not Is_Record_Type (Current_Scope)
+ then
+ Temp :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Etyp, Loc));
+
+ if Nkind (Expression (N)) = N_Qualified_Expression then
+ Set_Expression (Decl, Expression (Expression (N)));
+ end if;
+
+ declare
+ Nod : Node_Id;
+
+ begin
+ Nod := Parent (N);
+ while Present (Nod) loop
+ exit when
+ Nkind (Nod) in N_Statement_Other_Than_Procedure_Call
+ or else Nkind (Nod) = N_Procedure_Call_Statement
+ or else Nkind (Nod) in N_Declaration;
+ Nod := Parent (Nod);
+ end loop;
+
+ Insert_Before (Nod, Decl);
+ Analyze (Decl);
+ end;
+
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+
+ Analyze_And_Resolve (N, PtrT);
+
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Local_Access_Discriminant;
+
+ -- Start of processing for Expand_N_Allocator
+
begin
-- RM E.2.3(22). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type
return;
end if;
+ -- Same if the allocator is an access discriminant for a local object:
+ -- instead of an allocator we create a local value and constrain the
+ -- the enclosing object with the corresponding access attribute.
+
+ if Is_Local_Access_Discriminant (N) then
+ return;
+ end if;
+
-- Handle case of qualified expression (other than optimization above)
if Nkind (Expression (N)) = N_Qualified_Expression then
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
+ pragma Assert (Present (Parent (Base_Type (PtrT))));
Expand_N_Full_Type_Declaration
(Parent (Base_Type (PtrT)));
end if;
if Controlled_Type (T) then
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
- if Ekind (PtrT) = E_Anonymous_Access_Type then
+
+ -- Anonymous access types created for access parameters
+ -- are attached to an explicitly constructed controller,
+ -- which ensures that they can be finalized properly, even
+ -- if their deallocation might not happen. The list
+ -- associated with the controller is doubly-linked. For
+ -- other anonymous access types, the object may end up
+ -- on the global final list which is singly-linked.
+ -- Work needed for access discriminants in Ada 2005 ???
+
+ if Ekind (PtrT) = E_Anonymous_Access_Type
+ and then
+ Nkind (Associated_Node_For_Itype (PtrT))
+ not in N_Subprogram_Specification
+ then
Attach_Level := Uint_1;
else
Attach_Level := Uint_2;
end if;
+
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
if Is_Tagged_Type (Typl) then
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already notified such violation.
+
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
+
-- If this is derived from an untagged private type completed
-- with a tagged type, it does not have a full view, so we
-- use the primitive operations of the private type.
and then (not Is_Entity_Name (Pfx)
or else not Index_Checks_Suppressed (Entity (Pfx)))
and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
+
+ -- Do not enable range check to nodes associated with the frontend
+ -- expansion of the dispatch table. We first check if Ada.Tags is
+ -- already loaded to avoid the addition of an undesired dependence
+ -- on such run-time unit.
+
+ and then not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr))
then
Enable_Range_Check (Discrete_Range (N));
end if;
-- situation correctly in the assignment statement expansion).
-- 2. Prefix of indexed component (the slide is optimized away
- -- in this case, see the start of Expand_N_Slice.
+ -- in this case, see the start of Expand_N_Slice.)
-- 3. Object renaming declaration, since we want the name of
-- the slice, not the value.
return;
end if;
- -- Oherwise, proceed with processing tagged conversion
+ -- Otherwise, proceed with processing tagged conversion
declare
Actual_Operand_Type : Entity_Id;
or else
(Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
then
- -- Special processing required if the conversion is the expression
- -- of a Truncation attribute reference. In this case we replace:
-
- -- ityp (ftyp'Truncation (x))
-
- -- by
-
- -- ityp (x)
-
- -- with the Float_Truncate flag set. This is clearly more efficient
-
- if Nkind (Operand) = N_Attribute_Reference
- and then Attribute_Name (Operand) = Name_Truncation
- then
- Rewrite (Operand,
- Relocate_Node (First (Expressions (Operand))));
- Set_Float_Truncate (N, True);
- end if;
-
-- One more check here, gcc is still not able to do conversions of
-- this type with proper overflow checking, and so gigi is doing an
-- approximation of what is required by doing floating-point compares
-- with the end-point. But that can lose precision in some cases, and
-- give a wrong result. Converting the operand to Universal_Real is
-- helpful, but still does not catch all cases with 64-bit integers
- -- on targets with only 64-bit floats ???
+ -- on targets with only 64-bit floats
+
+ -- The above comment seems obsoleted by Apply_Float_Conversion_Check
+ -- Can this code be removed ???
if Do_Range_Check (Operand) then
Rewrite (Operand,
-- is usually implemented by looking in the ancestor tables contained in
-- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
+ -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
+ -- function IW_Membership which is usually implemented by looking in the
+ -- table of abstract interface types plus the ancestor table contained in
+ -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
+
function Tagged_Membership (N : Node_Id) return Node_Id is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
if Is_Class_Wide_Type (Right_Type) then
+ -- No need to issue a run-time check if we statically know that the
+ -- result of this membership test is always true. For example,
+ -- considering the following declarations:
+
+ -- type Iface is interface;
+ -- type T is tagged null record;
+ -- type DT is new T and Iface with null record;
+
+ -- Obj1 : T;
+ -- Obj2 : DT;
+
+ -- These membership tests are always true:
+
+ -- Obj1 in T'Class
+ -- Obj2 in T'Class;
+ -- Obj2 in Iface'Class;
+
+ -- We do not need to handle cases where the membership is illegal.
+ -- For example:
+
+ -- Obj1 in DT'Class; -- Compile time error
+ -- Obj1 in Iface'Class; -- Compile time error
+
+ if not Is_Class_Wide_Type (Left_Type)
+ and then (Is_Parent (Etype (Right_Type), Left_Type)
+ or else (Is_Interface (Etype (Right_Type))
+ and then Interface_Present_In_Ancestor
+ (Typ => Left_Type,
+ Iface => Etype (Right_Type))))
+ then
+ return New_Reference_To (Standard_True, Loc);
+ end if;
+
-- Ada 2005 (AI-251): Class-wide applied to interfaces
if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
- -- Give support to: "Iface_CW_Typ in Typ'Class"
+ -- Support to: "Iface_CW_Typ in Typ'Class"
or else Is_Interface (Left_Type)
then
else
return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
- Parameter_Associations => New_List (
- Obj_Tag,
+ Build_CW_Membership (Loc,
+ Obj_Tag_Node => Obj_Tag,
+ Typ_Tag_Node =>
New_Reference_To (
Node (First_Elmt
(Access_Disp_Table (Root_Type (Right_Type)))),
- Loc)));
+ Loc));
end if;
+ -- Right_Type is not a class-wide type
+
else
- return
- Make_Op_Eq (Loc,
- Left_Opnd => Obj_Tag,
- Right_Opnd =>
- New_Reference_To
- (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
+ -- No need to check the tag of the object if Right_Typ is abstract
+
+ if Is_Abstract_Type (Right_Type) then
+ return New_Reference_To (Standard_False, Loc);
+
+ else
+ return
+ Make_Op_Eq (Loc,
+ Left_Opnd => Obj_Tag,
+ Right_Opnd =>
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
+ end if;
end if;
end Tagged_Membership;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Disp; use Exp_Disp;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
procedure Set_Slice_Subtype (N : Node_Id);
-- Build subtype of array type, with the range specified by the slice
+ procedure Simplify_Type_Conversion (N : Node_Id);
+ -- Called after N has been resolved and evaluated, but before range checks
+ -- have been applied. Currently simplifies a combination of floating-point
+ -- to integer conversion and Truncation attribute.
+
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous
-- if there is only one applicable fixed point type. Determining whether
-- Start of processing for Check_Initialization_Call
begin
- -- Nothing to do if functions do not use the secondary stack for
- -- returns (i.e. they use a depressed stack pointer instead).
-
- if Functions_Return_By_DSP_On_Target then
- return;
+ -- Establish a transient scope if the type needs it
- -- Otherwise establish a transient scope if the type needs it
-
- elsif Uses_SS (Typ) then
+ if Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
end if;
end Check_Initialization_Call;
N, It.Nam);
end if;
- Error_Msg_N
- ("\\possible interpretation#!", N);
Ambiguous := True;
+
+ if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("\\possible interpretation (inherited)#!", N);
+ else
+ Error_Msg_N ("\\possible interpretation#!", N);
+ end if;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
-- By default, the error message refers to the candidate
- -- interpretation. But if it is a predefined operator,
- -- it is implicitly declared at the declaration of
- -- the type of the operand. Recover the sloc of that
- -- declaration for the error message.
+ -- interpretation. But if it is a predefined operator, it
+ -- is implicitly declared at the declaration of the type
+ -- of the operand. Recover the sloc of that declaration
+ -- for the error message.
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Right_Opnd (N))
- and then Scope (Base_Type (Etype (Right_Opnd (N))))
- /= Standard_Standard
+ and then Scope (Base_Type (Etype (Right_Opnd (N)))) /=
+ Standard_Standard
then
Err_Type := First_Subtype (Etype (Right_Opnd (N)));
elsif Nkind (N) in N_Binary_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Left_Opnd (N))
- and then Scope (Base_Type (Etype (Left_Opnd (N))))
- /= Standard_Standard
+ and then Scope (Base_Type (Etype (Left_Opnd (N)))) /=
+ Standard_Standard
then
Err_Type := First_Subtype (Etype (Left_Opnd (N)));
Err_Type := It.Nam;
Error_Msg_Sloc :=
Sloc (Associated_Node_For_Itype (Err_Type));
-
else
Err_Type := Empty;
end if;
end if;
end if;
- -- We have a matching interpretation, Expr_Type is the
- -- type from this interpretation, and Seen is the entity.
+ -- We have a matching interpretation, Expr_Type is the type
+ -- from this interpretation, and Seen is the entity.
- -- For an operator, just set the entity name. The type will
- -- be set by the specific operator resolution routine.
+ -- For an operator, just set the entity name. The type will be
+ -- set by the specific operator resolution routine.
if Nkind (N) in N_Op then
Set_Entity (N, Seen);
Set_Etype (N, Expr_Type);
-- For an explicit dereference, attribute reference, range,
- -- short-circuit form (which is not an operator node),
- -- or a call with a name that is an explicit dereference,
- -- there is nothing to be done at this point.
+ -- short-circuit form (which is not an operator node), or call
+ -- with a name that is an explicit dereference, there is
+ -- nothing to be done at this point.
elsif Nkind (N) = N_Explicit_Dereference
or else Nkind (N) = N_Attribute_Reference
then
null;
- -- For procedure or function calls, set the type of the
- -- name, and also the entity pointer for the prefix
+ -- For procedure or function calls, set the type of the name,
+ -- and also the entity pointer for the prefix
elsif (Nkind (N) = N_Procedure_Call_Statement
or else Nkind (N) = N_Function_Call)
if not Found then
if Typ /= Any_Type then
- -- If type we are looking for is Void, then this is the
- -- procedure call case, and the error is simply that what
- -- we gave is not a procedure name (we think of procedure
- -- calls as expressions with types internally, but the user
- -- doesn't think of them this way!)
+ -- If type we are looking for is Void, then this is the procedure
+ -- call case, and the error is simply that what we gave is not a
+ -- procedure name (we think of procedure calls as expressions with
+ -- types internally, but the user doesn't think of them this way!)
if Typ = Standard_Void_Type then
("cannot use function & in a procedure call",
Name (N), Entity (Name (N)));
- -- Otherwise give general message (not clear what cases
- -- this covers, but no harm in providing for them!)
+ -- Otherwise give general message (not clear what cases this
+ -- covers, but no harm in providing for them!)
else
Error_Msg_N ("expect procedure name in procedure call", N);
-- Otherwise we do have a subexpression with the wrong type
- -- Check for the case of an allocator which uses an access
- -- type instead of the designated type. This is a common
- -- error and we specialize the message, posting an error
- -- on the operand of the allocator, complaining that we
- -- expected the designated type of the allocator.
+ -- Check for the case of an allocator which uses an access type
+ -- instead of the designated type. This is a common error and we
+ -- specialize the message, posting an error on the operand of the
+ -- allocator, complaining that we expected the designated type of
+ -- the allocator.
elsif Nkind (N) = N_Allocator
and then Ekind (Typ) in Access_Kind
Wrong_Type (Expression (N), Designated_Type (Typ));
Found := True;
- -- Check for view mismatch on Null in instances, for
- -- which the view-swapping mechanism has no identifier.
+ -- Check for view mismatch on Null in instances, for which the
+ -- view-swapping mechanism has no identifier.
elsif (In_Instance or else In_Inlined_Body)
and then (Nkind (N) = N_Null)
Elmt := First (Component_Associations (Aggr));
while Present (Elmt) loop
- -- Nothing to check is this is a default-
- -- initialized component. The box will be
- -- be replaced by the appropriate call during
- -- late expansion.
+ -- If this is a default-initialized component, then
+ -- there is nothing to check. The box will be
+ -- replaced by the appropriate call during late
+ -- expansion.
if not Box_Present (Elmt) then
Check_Elmt (Expression (Elmt));
when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type);
- when N_Membership_Test
- => Resolve_Membership_Op (N, Ctx_Type);
-
when N_Indexed_Component
=> Resolve_Indexed_Component (N, Ctx_Type);
when N_Integer_Literal
=> Resolve_Integer_Literal (N, Ctx_Type);
+ when N_Membership_Test
+ => Resolve_Membership_Op (N, Ctx_Type);
+
when N_Null => Resolve_Null (N, Ctx_Type);
when N_Op_And | N_Op_Or | N_Op_Xor
Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
end if;
+
+ -- Ada 2005, AI-162:If the actual is an allocator, the
+ -- innermost enclosing statement is the master of the
+ -- created object.
+
+ if Is_Controlled (DDT)
+ or else Has_Task (DDT)
+ then
+ Establish_Transient_Scope (A, False);
+ end if;
end;
end if;
-- Check that subprograms don't have improper controlling
-- arguments (RM 3.9.2 (9))
+ -- A primitive operation may have an access parameter of an
+ -- incomplete tagged type, but a dispatching call is illegal
+ -- if the type is still incomplete.
+
if Is_Controlling_Formal (F) then
Set_Is_Controlling_Actual (A);
+
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type then
+ declare
+ Desig : constant Entity_Id := Designated_Type (Etype (F));
+ begin
+ if Ekind (Desig) = E_Incomplete_Type
+ and then No (Full_View (Desig))
+ and then No (Non_Limited_View (Desig))
+ then
+ Error_Msg_NE
+ ("premature use of incomplete type& " &
+ "in dispatching call", A, Desig);
+ end if;
+ end;
+ end if;
+
elsif Nkind (A) = N_Explicit_Dereference then
Validate_Remote_Access_To_Class_Wide_Type (A);
end if;
Set_Etype (N, Base_Type (Typ));
end if;
- if Is_Abstract (Typ) then
+ if Is_Abstract_Type (Typ) then
Error_Msg_N ("type of allocator cannot be abstract", N);
end if;
-- when the type of the component is an access to the array type. In
-- this case the call is truly ambiguous.
- elsif Needs_No_Actuals (Nam)
+ elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
and then
((Is_Array_Type (Etype (Nam))
and then Covers (Typ, Component_Type (Etype (Nam))))
Set_Entity (Subp, Nam);
if Component_Type (Ret_Type) /= Any_Type then
- Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Subp),
- Expressions => Parameter_Associations (N));
+ if Needs_No_Actuals (Nam) then
+
+ -- Indexed call to a parameterless function
+
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp),
+ Expressions => Parameter_Associations (N));
+ else
+ -- An Ada 2005 prefixed call to a primitive operation
+ -- whose first parameter is the prefix. This prefix was
+ -- prepended to the parameter list, which is actually a
+ -- list of indices. Remove the prefix in order to build
+ -- the proper indexed component.
+
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp,
+ Parameter_Associations =>
+ New_List
+ (Remove_Head (Parameter_Associations (N)))),
+ Expressions => Parameter_Associations (N));
+ end if;
-- Since we are correcting a node classification error made
-- by the parser, we call Replace rather than Rewrite.
-- Create a transient scope if the resulting type requires it
- -- There are 3 notable exceptions: in init procs, the transient scope
+ -- There are 4 notable exceptions: in init procs, the transient scope
-- overhead is not needed and even incorrect due to the actual expansion
- -- of adjust calls; the second case is enumeration literal pseudo calls,
- -- the other case is intrinsic subprograms (Unchecked_Conversion and
+ -- of adjust calls; the second case is enumeration literal pseudo calls;
+ -- the third case is intrinsic subprograms (Unchecked_Conversion and
-- source information functions) that do not use the secondary stack
- -- even though the return type is unconstrained.
+ -- even though the return type is unconstrained; the fourth case is a
+ -- call to a build-in-place function, since such functions may allocate
+ -- their result directly in a target object, and cases where the result
+ -- does get allocated in the secondary stack are checked for within the
+ -- specialized Exp_Ch6 procedures for expanding build-in-place calls.
-- If this is an initialization call for a type whose initialization
-- uses the secondary stack, we also need to create a transient scope
elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
+ and then not Is_Build_In_Place_Function (Nam)
and then Ekind (Nam) /= E_Enumeration_Literal
and then not Within_Init_Proc
and then not Is_Intrinsic_Subprogram (Nam)
then
- Establish_Transient_Scope
- (N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ Establish_Transient_Scope (N, Sec_Stack => True);
-- If the call appears within the bounds of a loop, it will
-- be rewritten and reanalyzed, nothing left to do here.
then
Check_Dispatching_Call (N);
- elsif Is_Abstract (Nam)
+ elsif Ekind (Nam) /= E_Subprogram_Type
+ and then Is_Abstract_Subprogram (Nam)
and then not In_Instance
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
- Establish_Transient_Scope (N,
- Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ Establish_Transient_Scope (N, Sec_Stack => True);
end if;
end Resolve_Entry_Call;
elsif T = Any_Access
or else Ekind (T) = E_Allocator_Type
+ or else Ekind (T) = E_Access_Attribute_Type
then
T := Find_Unique_Access_Type;
Resolve (L, T);
Resolve (R, T);
+ -- If the unique type is a class-wide type then it will be expanded
+ -- into a dispatching call to the predefined primitive. Therefore we
+ -- check here for potential violation of such restriction.
+
+ if Is_Class_Wide_Type (T) then
+ Check_Restriction (No_Dispatching_Calls, N);
+ end if;
+
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Is_Entity_Name (R)
then
Eval_Relational_Op (N);
elsif Nkind (N) = N_Op_Ne
- and then Is_Abstract (Entity (N))
+ and then Is_Abstract_Subprogram (Entity (N))
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
end loop;
end if;
- Warn_On_Suspicious_Index (Name, First (Expressions (N)));
- Eval_Indexed_Component (N);
+ -- Do not generate the warning on suspicious index if we are analyzing
+ -- package Ada.Tags; otherwise we will report the warning with the
+ -- Prims_Ptr field of the dispatch table.
+
+ if Scope (Etype (Prefix (N))) = Standard_Standard
+ or else not
+ Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))),
+ Ada_Tags)
+ then
+ Warn_On_Suspicious_Index (Name, First (Expressions (N)));
+ Eval_Indexed_Component (N);
+ end if;
end Resolve_Indexed_Component;
-----------------------------
Index := First_Index (Array_Type);
Resolve (Drange, Base_Type (Etype (Index)));
- if Nkind (Drange) = N_Range then
+ if Nkind (Drange) = N_Range
+
+ -- Do not apply the range check to nodes associated with the
+ -- frontend expansion of the dispatch table. We first check
+ -- if Ada.Tags is already loaded to void the addition of an
+ -- undesired dependence on such run-time unit.
+
+ and then not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N)))
+ = RTE_Record_Component (RE_Prims_Ptr))
+ then
Apply_Range_Check (Drange, Etype (Index));
end if;
end if;
Eval_Type_Conversion (N);
+ -- Even when evaluation is not possible, we may be able to simplify
+ -- the conversion or its expression. This needs to be done before
+ -- applying checks, since otherwise the checks may use the original
+ -- expression and defeat the simplifications. The is specifically
+ -- the case for elimination of the floating-point Truncation
+ -- attribute in float-to-int conversions.
+
+ Simplify_Type_Conversion (N);
+
-- If after evaluation, we still have a type conversion, then we
-- may need to apply checks required for a subtype conversion.
end if;
-- Ada 2005 (AI-251): Handle conversions to abstract interface types
+ -- No need to perform any interface conversion if the type of the
+ -- expression coincides with the target type.
- if Ada_Version >= Ada_05 and then Expander_Active then
+ if Ada_Version >= Ada_05
+ and then Expander_Active
+ and then Opnd_Type /= Target_Type
+ then
if Is_Access_Type (Target_Type) then
Target_Type := Directly_Designated_Type (Target_Type);
end if;
Hi : Uint;
begin
- -- Generate warning for expressions like -5 mod 3
-
- if Warn_On_Questionable_Missing_Parens
- and then Paren_Count (N) = 0
- and then (Nkind (N) = N_Op_Minus or else Nkind (N) = N_Op_Plus)
- and then Paren_Count (Right_Opnd (N)) = 0
- and then Nkind (Right_Opnd (N)) in N_Multiplying_Operator
- and then Comes_From_Source (N)
- then
- Error_Msg_N
- ("?unary minus expression should be parenthesized here", N);
- end if;
+ -- Deal with intrincis unary operators
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
return;
end if;
+ -- Deal with universal cases
+
if Etype (R) = Universal_Integer
- or else Etype (R) = Universal_Real
+ or else
+ Etype (R) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
end if;
end if;
+ -- Deal with reference generation
+
Check_Unset_Reference (R);
Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N);
Enable_Overflow_Check (N);
end if;
end if;
+
+ -- Generate warning for expressions like -5 mod 3 for integers. No
+ -- need to worry in the floating-point case, since parens do not affect
+ -- the result so there is no point in giving in a warning.
+
+ declare
+ Norig : constant Node_Id := Original_Node (N);
+ Rorig : Node_Id;
+ Val : Uint;
+ HB : Uint;
+ LB : Uint;
+ Lval : Uint;
+ Opnd : Node_Id;
+
+ begin
+ if Warn_On_Questionable_Missing_Parens
+ and then Comes_From_Source (Norig)
+ and then Is_Integer_Type (Typ)
+ and then Nkind (Norig) = N_Op_Minus
+ then
+ Rorig := Original_Node (Right_Opnd (Norig));
+
+ -- We are looking for cases where the right operand is not
+ -- parenthesized, and is a bianry operator, multiply, divide, or
+ -- mod. These are the cases where the grouping can affect results.
+
+ if Paren_Count (Rorig) = 0
+ and then (Nkind (Rorig) = N_Op_Mod
+ or else
+ Nkind (Rorig) = N_Op_Multiply
+ or else
+ Nkind (Rorig) = N_Op_Divide)
+ then
+ -- For mod, we always give the warning, since the value is
+ -- affected by the parenthesization (e.g. (-5) mod 315 /=
+ -- (5 mod 315)). But for the other cases, the only concern is
+ -- overflow, e.g. for the case of 8 big signed (-(2 * 64)
+ -- overflows, but (-2) * 64 does not). So we try to give the
+ -- message only when overflow is possible.
+
+ if Nkind (Rorig) /= N_Op_Mod
+ and then Compile_Time_Known_Value (R)
+ then
+ Val := Expr_Value (R);
+
+ if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
+ HB := Expr_Value (Type_High_Bound (Typ));
+ else
+ HB := Expr_Value (Type_High_Bound (Base_Type (Typ)));
+ end if;
+
+ if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
+ LB := Expr_Value (Type_Low_Bound (Typ));
+ else
+ LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
+ end if;
+
+ -- Note that the test below is deliberately excluding
+ -- the largest negative number, since that is a potentially
+ -- troublesome case (e.g. -2 * x, where the result is the
+ -- largest negative integer has an overflow with 2 * x).
+
+ if Val > LB and then Val <= HB then
+ return;
+ end if;
+ end if;
+
+ -- For the multiplication case, the only case we have to worry
+ -- about is when (-a)*b is exactly the largest negative number
+ -- so that -(a*b) can cause overflow. This can only happen if
+ -- a is a power of 2, and more generally if any operand is a
+ -- constant that is not a power of 2, then the parentheses
+ -- cannot affect whether overflow occurs. We only bother to
+ -- test the left most operand
+
+ -- Loop looking at left operands for one that has known value
+
+ Opnd := Rorig;
+ Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop
+ if Compile_Time_Known_Value (Left_Opnd (Opnd)) then
+ Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd)));
+
+ -- Operand value of 0 or 1 skips warning
+
+ if Lval <= 1 then
+ return;
+
+ -- Otherwise check power of 2, if power of 2, warn, if
+ -- anything else, skip warning.
+
+ else
+ while Lval /= 2 loop
+ if Lval mod 2 = 1 then
+ return;
+ else
+ Lval := Lval / 2;
+ end if;
+ end loop;
+
+ exit Opnd_Loop;
+ end if;
+ end if;
+
+ -- Keep looking at left operands
+
+ Opnd := Left_Opnd (Opnd);
+ end loop Opnd_Loop;
+
+ -- For rem or "/" we can only have a problematic situation
+ -- if the divisor has a value of minus one or one. Otherwise
+ -- overflow is impossible (divisor > 1) or we have a case of
+ -- division by zero in any case.
+
+ if (Nkind (Rorig) = N_Op_Divide
+ or else
+ Nkind (Rorig) = N_Op_Rem)
+ and then Compile_Time_Known_Value (Right_Opnd (Rorig))
+ and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
+ then
+ return;
+ end if;
+
+ -- If we fall through warning should be issued
+
+ Error_Msg_N
+ ("?unary minus expression should be parenthesized here", N);
+ end if;
+ end if;
+ end;
end Resolve_Unary_Op;
----------------------------------
begin
Index_Subtype :=
Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
- Drange := Make_Range (Loc, Low_Bound, High_Bound);
+ Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
Set_Scalar_Range (Index_Subtype, Drange);
Set_Parent (Drange, N);
Analyze_And_Resolve (Drange, Index_Type);
end if;
end Set_String_Literal_Subtype;
+ ------------------------------
+ -- Simplify_Type_Conversion --
+ ------------------------------
+
+ procedure Simplify_Type_Conversion (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Type_Conversion then
+ declare
+ Operand : constant Node_Id := Expression (N);
+ Target_Typ : constant Entity_Id := Etype (N);
+ Opnd_Typ : constant Entity_Id := Etype (Operand);
+
+ begin
+ if Is_Floating_Point_Type (Opnd_Typ)
+ and then
+ (Is_Integer_Type (Target_Typ)
+ or else (Is_Fixed_Point_Type (Target_Typ)
+ and then Conversion_OK (N)))
+ and then Nkind (Operand) = N_Attribute_Reference
+ and then Attribute_Name (Operand) = Name_Truncation
+
+ -- Special processing required if the conversion is the expression
+ -- of a Truncation attribute reference. In this case we replace:
+
+ -- ityp (ftyp'Truncation (x))
+
+ -- by
+
+ -- ityp (x)
+
+ -- with the Float_Truncate flag set, which is more efficient
+
+ then
+ Rewrite (Operand,
+ Relocate_Node (First (Expressions (Operand))));
+ Set_Float_Truncate (N, True);
+ end if;
+ end;
+ end if;
+ end Simplify_Type_Conversion;
+
-----------------------------
-- Unique_Fixed_Point_Type --
-----------------------------
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
- -- Ada 2005 (AI-251): The conversion of a tagged type to an
- -- abstract interface type is always valid
+ -- Ada 2005 (AI-251): The conversion to/from interface types is
+ -- always valid
- elsif Is_Interface (Target_Type) then
+ elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
return True;
elsif Is_Access_Type (Opnd_Type)
end if;
declare
- Target : constant Entity_Id := Designated_Type (Target_Type);
- Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
+ function Full_Designated_Type (T : Entity_Id) return Entity_Id;
+ -- Helper function to handle limited views
+
+ --------------------------
+ -- Full_Designated_Type --
+ --------------------------
+
+ function Full_Designated_Type (T : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id := Designated_Type (T);
+ begin
+ if From_With_Type (Desig)
+ and then Is_Incomplete_Type (Desig)
+ and then Present (Non_Limited_View (Desig))
+ then
+ return Non_Limited_View (Desig);
+ else
+ return Desig;
+ end if;
+ end Full_Designated_Type;
+
+ Target : constant Entity_Id := Full_Designated_Type (Target_Type);
+ Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type);
+
+ Same_Base : constant Boolean :=
+ Base_Type (Target) = Base_Type (Opnd);
begin
if Is_Tagged_Type (Target) then
return Valid_Tagged_Conversion (Target, Opnd);
else
- if Base_Type (Target) /= Base_Type (Opnd) then
+ if not Same_Base then
Error_Msg_NE
("target designated type not compatible with }",
N, Base_Type (Opnd));
or else
Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
- and then Conversion_Check
- (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
- "illegal operand for access subprogram conversion")
then
+ if
+ Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
+ then
+ Error_Msg_N
+ ("illegal attempt to store anonymous access to subprogram",
+ Operand);
+ Error_Msg_N
+ ("\value has deeper accessibility than any master " &
+ "('R'M 3.10.2 (13))",
+ Operand);
+
+ if Is_Entity_Name (Operand)
+ and then Ekind (Entity (Operand)) = E_In_Parameter
+ then
+ Error_Msg_NE
+ ("\use named access type for& instead of access parameter",
+ Operand, Entity (Operand));
+ end if;
+ end if;
+
-- Check that the designated types are subtype conformant
Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
projects / gcc.git / commitdiff