Skip to content

R
riscv-gcc-1
Commit 0669bebe by Geert Bosch Committed by Arnaud Charlet
Options

exp_ch4.adb (Expand_N_Type_Conversion): Remove special processing for conversion… 

exp_ch4.adb (Expand_N_Type_Conversion): Remove special processing for conversion of a Float_Type'Truncation to integer.

2007-04-06  Geert Bosch  <bosch@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Bob Duff  <duff@adacore.com>

	* exp_ch4.adb (Expand_N_Type_Conversion): Remove special processing
	for conversion of a Float_Type'Truncation to integer.

	* exp_attr.adb (Is_Inline_Floating_Point_Attribute): New function to
	check if a node is an attribute that can be handled directly by the
	back end.
	(Expand_N_Attribute_Reference): Suppress expansion of floating-point
	attributes that can be handled directly by the back end.
	(Expand_N_Attribute_Reference, case 'Access and 'Unchecked_Access):
	use new predicate Is_Access_Protected_Subprogram_Type.
	(Expand_N_Attribute_Reference, case 'Write): The reference is legal for
	and Unchecked_Union if it is generated as part of the default  Output
	procedure for a type with default discriminants.
	(Expand_N_Attribute_Reference): Avoid the expansion of dispatching calls
	if we are compiling under restriction No_Dispatching_Calls.
	(Constrained): Use Underlying_Type, in case the type is private without
	discriminants, but the full type has discriminants.
	(Expand_N_Attribute_Reference): Replace call to Get_Access_Level by
	call to Build_Get_Access_Level.
	(Expand_N_Attribute_Reference): The use of 'Address with class-wide
	interface objects requires a call to the run-time subprogram that
	returns the base address of the object.
	(Valid_Conversion): Improve error message on illegal attempt to store
	an anonymous access to subprogram value into a record component.

	* sem_res.adb (Resolve_Equality_Op): Detect ambiguity for "X'Access =
	null".
	(Simplify_Type_Conversion): New procedure that performs simplification
	of Int_Type (Float_Type'Truncation (X)).
	(Resolve_Type_Conversion): Call above procedure after resolving operand
	and before performing checks. This replaces the existing ineffective
	code in Exp_Ch4.
	(Set_String_Literal_Subtype): When creating the internal static lower
	bound subtype for a string literal, use a newly created copy of the
	subtree representing the lower bound.
	(Resolve_Call): Exclude build-in-place function calls from transient
	scope treatment. Update comments to describe this exception.
	(Resolve_Equality_Op): In case of dispatching call check violation of
	restriction No_Dispatching_Calls.
	(Resolve_Call): If the call returns an array, the context imposes the
	component type of the array, and the function has one non-defaulted
	parameter, rewrite the call as the indexing of a call with a single
	parameter, to handle an Ada 2005 syntactic ambiguity for calls written
	in prefix form.
	(Resolve_Actuals): If an actual is an allocator for an access parameter,
	the master of the created object is the innermost enclosing statement.
	(Remove_Conversions): For a binary operator, check if type of second
	formal is numeric, to check if an abstract interpretation is present
	in the case of exponentiation as well.

From-SVN: r123552
parent ea1941af
Showing with 735 additions and 180 deletions
gcc/ada/exp_attr.adb
......@@ -28,6 +28,7 @@ with Atree; use Atree;
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;
......@@ -160,6 +161,12 @@ package body Exp_Attr is
-- 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 --
----------------------------------
......@@ -497,7 +504,7 @@ package body Exp_Attr is
-- 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
......@@ -665,7 +672,7 @@ package body Exp_Attr is
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
......@@ -795,6 +802,23 @@ package body Exp_Attr is
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
......@@ -829,6 +853,15 @@ package body Exp_Attr is
-- 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
......@@ -1327,8 +1360,13 @@ package body Exp_Attr is
-- 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,
......@@ -1350,7 +1388,7 @@ package body Exp_Attr is
(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;
......@@ -2013,6 +2051,14 @@ package body Exp_Attr is
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;
......@@ -2430,10 +2476,13 @@ package body Exp_Attr is
-- 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 --
......@@ -2707,6 +2756,15 @@ package body Exp_Attr is
-- 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);
......@@ -2730,21 +2788,18 @@ package body Exp_Attr is
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 (
......@@ -2775,9 +2830,9 @@ package body Exp_Attr is
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
......@@ -3450,6 +3505,15 @@ package body Exp_Attr is
-- 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
......@@ -3912,10 +3976,13 @@ package body Exp_Attr is
----------------
-- 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 --
......@@ -3923,10 +3990,13 @@ package body Exp_Attr is
-- 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 --
......@@ -3999,7 +4069,7 @@ package body Exp_Attr is
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
......@@ -4184,7 +4254,7 @@ package body Exp_Attr is
-- 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);
......@@ -4667,9 +4737,14 @@ package body Exp_Attr is
-- 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));
......@@ -5038,4 +5113,24 @@ package body Exp_Attr is
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;
gcc/ada/exp_ch4.adb
......@@ -30,6 +30,7 @@ with Einfo; use Einfo;
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;
......@@ -46,6 +47,8 @@ with Inline; use Inline;
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;
......@@ -481,37 +484,47 @@ package body Exp_Ch4 is
-- 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;
......@@ -2489,6 +2502,72 @@ package body Exp_Ch4 is
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
......@@ -2581,6 +2660,14 @@ package body Exp_Ch4 is
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
......@@ -2721,6 +2808,7 @@ package body Exp_Ch4 is
-- 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;
......@@ -2895,11 +2983,26 @@ package body Exp_Ch4 is
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),
......@@ -4571,6 +4674,14 @@ package body Exp_Ch4 is
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.
......@@ -6420,6 +6531,18 @@ package body Exp_Ch4 is
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;
......@@ -6431,7 +6554,7 @@ package body Exp_Ch4 is
-- 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.
......@@ -6906,7 +7029,7 @@ package body Exp_Ch4 is
return;
end if;
-- Oherwise, proceed with processing tagged conversion
-- Otherwise, proceed with processing tagged conversion
declare
Actual_Operand_Type : Entity_Id;
......@@ -7072,32 +7195,16 @@ package body Exp_Ch4 is
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,
......@@ -8358,6 +8465,11 @@ package body Exp_Ch4 is
-- 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);
......@@ -8383,11 +8495,44 @@ package body Exp_Ch4 is
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
......@@ -8415,23 +8560,31 @@ package body Exp_Ch4 is
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;
......
gcc/ada/sem_res.adb
......@@ -32,6 +32,7 @@ with Einfo; use Einfo;
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;
......@@ -66,7 +67,6 @@ with Sinfo; use Sinfo;
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;
......@@ -215,6 +215,11 @@ package body Sem_Res is
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
......@@ -821,15 +826,9 @@ package body Sem_Res is
-- 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;
......@@ -1835,24 +1834,29 @@ package body Sem_Res is
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)));
......@@ -1865,8 +1869,8 @@ package body Sem_Res is
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)));
......@@ -1888,7 +1892,6 @@ package body Sem_Res is
Err_Type := It.Nam;
Error_Msg_Sloc :=
Sloc (Associated_Node_For_Itype (Err_Type));
else
Err_Type := Empty;
end if;
......@@ -1912,11 +1915,11 @@ package body Sem_Res is
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);
......@@ -1926,9 +1929,9 @@ package body Sem_Res is
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
......@@ -1942,8 +1945,8 @@ package body Sem_Res is
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)
......@@ -1985,11 +1988,10 @@ package body Sem_Res is
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
......@@ -2003,8 +2005,8 @@ package body Sem_Res is
("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);
......@@ -2014,11 +2016,11 @@ package body Sem_Res is
-- 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
......@@ -2028,8 +2030,8 @@ package body Sem_Res is
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)
......@@ -2087,10 +2089,10 @@ package body Sem_Res is
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));
......@@ -2293,15 +2295,15 @@ package body Sem_Res is
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
......@@ -2773,6 +2775,16 @@ package body Sem_Res is
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;
......@@ -2959,8 +2971,28 @@ package body Sem_Res is
-- 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;
......@@ -3070,7 +3102,7 @@ package body Sem_Res is
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;
......@@ -3924,7 +3956,7 @@ package body Sem_Res is
-- 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))))
......@@ -3950,12 +3982,33 @@ package body Sem_Res is
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.
......@@ -4110,12 +4163,16 @@ package body Sem_Res is
-- 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
......@@ -4136,12 +4193,12 @@ package body Sem_Res is
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.
......@@ -4213,7 +4270,8 @@ package body Sem_Res is
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);
......@@ -4978,8 +5036,7 @@ package body Sem_Res is
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;
......@@ -5073,6 +5130,7 @@ package body Sem_Res is
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;
......@@ -5086,6 +5144,14 @@ package body Sem_Res is
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)
......@@ -5112,7 +5178,7 @@ package body Sem_Res is
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;
......@@ -5341,8 +5407,18 @@ package body Sem_Res is
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;
-----------------------------
......@@ -6498,7 +6574,20 @@ package body Sem_Res is
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;
......@@ -6881,6 +6970,15 @@ package body Sem_Res is
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.
......@@ -6929,8 +7027,13 @@ package body Sem_Res is
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;
......@@ -6994,18 +7097,7 @@ package body Sem_Res is
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
......@@ -7016,8 +7108,11 @@ package body Sem_Res is
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;
......@@ -7038,6 +7133,8 @@ package body Sem_Res is
end if;
end if;
-- Deal with reference generation
Check_Unset_Reference (R);
Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N);
......@@ -7051,6 +7148,135 @@ package body Sem_Res is
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;
----------------------------------
......@@ -7318,7 +7544,7 @@ package body Sem_Res is
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);
......@@ -7347,6 +7573,47 @@ package body Sem_Res is
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 --
-----------------------------
......@@ -7643,10 +7910,10 @@ package body Sem_Res is
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)
......@@ -7988,15 +8255,38 @@ package body Sem_Res is
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));
......@@ -8031,10 +8321,27 @@ package body Sem_Res is
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),
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment