with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
end if;
end Cannot_Raise_Constraint_Error;
+ -----------------------------------------
+ -- Check_Dynamically_Tagged_Expression --
+ -----------------------------------------
+
+ procedure Check_Dynamically_Tagged_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ begin
+ pragma Assert (Is_Tagged_Type (Typ));
+
+ -- In order to avoid spurious errors when analyzing the expanded code,
+ -- this check is done only for nodes that come from source and for
+ -- actuals of generic instantiations.
+
+ if (Comes_From_Source (Related_Nod)
+ or else In_Generic_Actual (Expr))
+ and then (Is_Class_Wide_Type (Etype (Expr))
+ or else Is_Dynamically_Tagged (Expr))
+ and then Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+ end if;
+ end Check_Dynamically_Tagged_Expression;
+
--------------------------
-- Check_Fully_Declared --
--------------------------
end Denotes_Discriminant;
+ -------------------------
+ -- Denotes_Same_Object --
+ -------------------------
+
+ function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+ begin
+ -- If we have entity names, then must be same entity
+
+ if Is_Entity_Name (A1) then
+ if Is_Entity_Name (A2) then
+ return Entity (A1) = Entity (A2);
+ else
+ return False;
+ end if;
+
+ -- No match if not same node kind
+
+ elsif Nkind (A1) /= Nkind (A2) then
+ return False;
+
+ -- For selected components, must have same prefix and selector
+
+ elsif Nkind (A1) = N_Selected_Component then
+ return Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ and then
+ Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+
+ -- For explicit dereferences, prefixes must be same
+
+ elsif Nkind (A1) = N_Explicit_Dereference then
+ return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+
+ -- For indexed components, prefixes and all subscripts must be the same
+
+ elsif Nkind (A1) = N_Indexed_Component then
+ if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+ declare
+ Indx1 : Node_Id;
+ Indx2 : Node_Id;
+
+ begin
+ Indx1 := First (Expressions (A1));
+ Indx2 := First (Expressions (A2));
+ while Present (Indx1) loop
+
+ -- Shouldn't we be checking that values are the same???
+
+ if not Denotes_Same_Object (Indx1, Indx2) then
+ return False;
+ end if;
+
+ Next (Indx1);
+ Next (Indx2);
+ end loop;
+
+ return True;
+ end;
+ else
+ return False;
+ end if;
+
+ -- For slices, prefixes must match and bounds must match
+
+ elsif Nkind (A1) = N_Slice
+ and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ then
+ declare
+ Lo1, Lo2, Hi1, Hi2 : Node_Id;
+
+ begin
+ Get_Index_Bounds (Etype (A1), Lo1, Hi1);
+ Get_Index_Bounds (Etype (A2), Lo2, Hi2);
+
+ -- Check whether bounds are statically identical. There is no
+ -- attempt to detect partial overlap of slices.
+
+ -- What about an array and a slice of an array???
+
+ return Denotes_Same_Object (Lo1, Lo2)
+ and then Denotes_Same_Object (Hi1, Hi2);
+ end;
+
+ -- Literals will appear as indices. Isn't this where we should check
+ -- Known_At_Compile_Time at least if we are generating warnings ???
+
+ elsif Nkind (A1) = N_Integer_Literal then
+ return Intval (A1) = Intval (A2);
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Object;
+
+ -------------------------
+ -- Denotes_Same_Prefix --
+ -------------------------
+
+ function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
+
+ begin
+ if Is_Entity_Name (A1) then
+ if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+ return Denotes_Same_Object (A1, Prefix (A2))
+ or else Denotes_Same_Prefix (A1, Prefix (A2));
+ else
+ return False;
+ end if;
+
+ elsif Is_Entity_Name (A2) then
+ return Denotes_Same_Prefix (A2, A1);
+
+ elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
+ and then
+ Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
+ then
+ declare
+ Root1, Root2 : Node_Id;
+ Depth1, Depth2 : Int := 0;
+
+ begin
+ Root1 := Prefix (A1);
+ while not Is_Entity_Name (Root1) loop
+ if not Nkind_In
+ (Root1, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root1 := Prefix (Root1);
+ end if;
+
+ Depth1 := Depth1 + 1;
+ end loop;
+
+ Root2 := Prefix (A2);
+ while not Is_Entity_Name (Root2) loop
+ if not Nkind_In
+ (Root2, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root2 := Prefix (Root2);
+ end if;
+
+ Depth2 := Depth2 + 1;
+ end loop;
+
+ -- If both have the same depth and they do not denote the same
+ -- object, they are disjoint and not warning is needed.
+
+ if Depth1 = Depth2 then
+ return False;
+
+ elsif Depth1 > Depth2 then
+ Root1 := Prefix (A1);
+ for I in 1 .. Depth1 - Depth2 - 1 loop
+ Root1 := Prefix (Root1);
+ end loop;
+
+ return Denotes_Same_Object (Root1, A2);
+
+ else
+ Root2 := Prefix (A2);
+ for I in 1 .. Depth2 - Depth1 - 1 loop
+ Root2 := Prefix (Root2);
+ end loop;
+
+ return Denotes_Same_Object (A1, Root2);
+ end if;
+ end;
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Prefix;
+
----------------------
-- Denotes_Variable --
----------------------
end Find_Corresponding_Discriminant;
--------------------------
- -- Find_Overlaid_Object --
+ -- Find_Overlaid_Entity --
--------------------------
- function Find_Overlaid_Object (N : Node_Id) return Entity_Id is
- Expr : Node_Id;
+ procedure Find_Overlaid_Entity
+ (N : Node_Id;
+ Ent : out Entity_Id;
+ Off : out Boolean)
+ is
+ Expr : Node_Id;
begin
-- We are looking for one of the two following forms:
-- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address.
+ Ent := Empty;
+ Off := False;
+
if Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Name_Address
then
- -- This loop checks the form of the expression for Y'Address where Y
- -- is an object entity name. The first loop checks the original
- -- expression in the attribute definition clause. Subsequent loops
- -- check referenced constants.
-
Expr := Expression (N);
+
+ -- This loop checks the form of the expression for Y'Address,
+ -- using recursion to deal with intermediate constants.
+
loop
- -- Check for Y'Address where Y is an object entity
+ -- Check for Y'Address
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
- and then Is_Entity_Name (Prefix (Expr))
- and then Is_Object (Entity (Prefix (Expr)))
then
- return Entity (Prefix (Expr));
+ Expr := Prefix (Expr);
+ exit;
-- Check for Const where Const is a constant entity
-- Anything else does not need checking
else
- exit;
+ return;
end if;
end loop;
- end if;
- return Empty;
- end Find_Overlaid_Object;
+ -- This loop checks the form of the prefix for an entity,
+ -- using recursion to deal with intermediate components.
+
+ loop
+ -- Check for Y where Y is an entity
+
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
+ return;
+
+ -- Check for components
+
+ elsif
+ Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
+
+ Expr := Prefix (Expr);
+ Off := True;
+
+ -- Anything else does not need checking
+
+ else
+ return;
+ end if;
+ end loop;
+ end if;
+ end Find_Overlaid_Entity;
-------------------------
-- Find_Parameter_Type --
Default : Alignment_Result) return Alignment_Result
is
Result : Alignment_Result := Known_Compatible;
- -- Set to result if Problem_Prefix or Problem_Offset returns True.
- -- Note that once a value of Known_Incompatible is set, it is sticky
- -- and does not get changed to Unknown (the value in Result only gets
- -- worse as we go along, never better).
+ -- Holds the current status of the result. Note that once a value of
+ -- Known_Incompatible is set, it is sticky and does not get changed
+ -- to Unknown (the value in Result only gets worse as we go along,
+ -- never better).
- procedure Check_Offset (Offs : Uint);
- -- Called when Expr is a selected or indexed component with Offs set
- -- to resp Component_First_Bit or Component_Size. Checks that if the
- -- offset is specified it is compatible with the object alignment
- -- requirements. The value in Result is modified accordingly.
+ Offs : Uint := No_Uint;
+ -- Set to a factor of the offset from the base object when Expr is a
+ -- selected or indexed component, based on Component_Bit_Offset and
+ -- Component_Size respectively. A negative value is used to represent
+ -- a value which is not known at compile time.
procedure Check_Prefix;
-- Checks the prefix recursively in the case where the expression
-- compatible, or known incompatible), then set Result to R.
------------------
- -- Check_Offset --
- ------------------
-
- procedure Check_Offset (Offs : Uint) is
- begin
- -- Unspecified or zero offset is always OK
-
- if Offs = No_Uint or else Offs = Uint_0 then
- null;
-
- -- If we do not know required alignment, any non-zero offset is
- -- a potential problem (but certainly may be OK, so result is
- -- unknown).
-
- elsif Unknown_Alignment (Obj) then
- Set_Result (Unknown);
-
- -- If we know the required alignment, see if offset is compatible
-
- else
- if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then
- Set_Result (Known_Incompatible);
- end if;
- end if;
- end Check_Offset;
-
- ------------------
-- Check_Prefix --
------------------
Set_Result (Unknown);
end if;
- -- Check possible bad component offset and check prefix
+ -- Check prefix and component offset
- Check_Offset
- (Component_Bit_Offset (Entity (Selector_Name (Expr))));
Check_Prefix;
+ Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
-- If Expr is an indexed component, we must make sure there is no
-- potentially troublesome Component_Size clause and that the array
-- is not bit-packed.
elsif Nkind (Expr) = N_Indexed_Component then
+ declare
+ Typ : constant Entity_Id := Etype (Prefix (Expr));
+ Ind : constant Node_Id := First_Index (Typ);
- -- Bit packed array always generates unknown alignment
+ begin
+ -- Bit packed array always generates unknown alignment
- if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then
- Set_Result (Unknown);
- end if;
+ if Is_Bit_Packed_Array (Typ) then
+ Set_Result (Unknown);
+ end if;
- -- Check possible bad component size and check prefix
+ -- Check prefix and component offset
- Check_Offset (Component_Size (Etype (Prefix (Expr))));
- Check_Prefix;
+ Check_Prefix;
+ Offs := Component_Size (Typ);
+
+ -- Small optimization: compute the full offset when possible
+
+ if Offs /= No_Uint
+ and then Offs > Uint_0
+ and then Present (Ind)
+ and then Nkind (Ind) = N_Range
+ and then Compile_Time_Known_Value (Low_Bound (Ind))
+ and then Compile_Time_Known_Value (First (Expressions (Expr)))
+ then
+ Offs := Offs * (Expr_Value (First (Expressions (Expr)))
+ - Expr_Value (Low_Bound ((Ind))));
+ end if;
+ end;
end if;
+ -- If we have a null offset, the result is entirely determined by
+ -- the base object and has already been computed recursively.
+
+ if Offs = Uint_0 then
+ null;
+
-- Case where we know the alignment of the object
- if Known_Alignment (Obj) then
+ elsif Known_Alignment (Obj) then
declare
ObjA : constant Uint := Alignment (Obj);
- ExpA : Uint := No_Uint;
- SizA : Uint := No_Uint;
+ ExpA : Uint := No_Uint;
+ SizA : Uint := No_Uint;
begin
-- If alignment of Obj is 1, then we are always OK
-- Alignment of Obj is greater than 1, so we need to check
else
- -- See if Expr is an object with known alignment
+ -- If we have an offset, see if it is compatible
+
+ if Offs /= No_Uint and Offs > Uint_0 then
+ if Offs mod (System_Storage_Unit * ObjA) /= 0 then
+ Set_Result (Known_Incompatible);
+ end if;
+
+ -- See if Expr is an object with known alignment
- if Is_Entity_Name (Expr)
+ elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr))
then
ExpA := Alignment (Entity (Expr));
elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr));
+
+ -- Otherwise the alignment is unknown
+
+ else
+ Set_Result (Default);
end if;
-- If we got an alignment, see if it is acceptable
- if ExpA /= No_Uint then
- if ExpA < ObjA then
- Set_Result (Known_Incompatible);
- end if;
+ if ExpA /= No_Uint and then ExpA < ObjA then
+ Set_Result (Known_Incompatible);
+ end if;
- -- Case of Expr alignment unknown
+ -- If Expr is not a piece of a larger object, see if size
+ -- is given. If so, check that it is not too small for the
+ -- required alignment.
- else
- Set_Result (Default);
- end if;
+ if Offs /= No_Uint then
+ null;
- -- See if size is given. If so, check that it is not too
- -- small for the required alignment.
- -- See if Expr is an object with known alignment
+ -- See if Expr is an object with known size
- if Is_Entity_Name (Expr)
+ elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr))
then
SizA := Esize (Entity (Expr));
end if;
end;
+ -- If we do not know required alignment, any non-zero offset is a
+ -- potential problem (but certainly may be OK, so result is unknown).
+
+ elsif Offs /= No_Uint then
+ Set_Result (Unknown);
+
-- If we can't find the result by direct comparison of alignment
-- values, then there is still one case that we can determine known
-- result, and that is when we can determine that the types are the
if Known_Alignment (Entity (Expr))
and then
- UI_To_Int (Alignment (Entity (Expr)))
- < Ttypes.Maximum_Alignment
+ UI_To_Int (Alignment (Entity (Expr))) <
+ Ttypes.Maximum_Alignment
then
Set_Result (Unknown);
and then
(UI_To_Int (Esize (Entity (Expr))) mod
(Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
- /= 0
+ /= 0
then
Set_Result (Unknown);
-- Unknown, since that result will be set in any case.
elsif Default /= Unknown
- and then (Has_Size_Clause (Etype (Expr))
+ and then (Has_Size_Clause (Etype (Expr))
or else
Has_Alignment_Clause (Etype (Expr)))
then
----------------------
function Has_Declarations (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
- begin
- return K = N_Accept_Statement
- or else K = N_Block_Statement
- or else K = N_Compilation_Unit_Aux
- or else K = N_Entry_Body
- or else K = N_Package_Body
- or else K = N_Protected_Body
- or else K = N_Subprogram_Body
- or else K = N_Task_Body
- or else K = N_Package_Specification;
+ begin
+ return Nkind_In (Nkind (N), N_Accept_Statement,
+ N_Block_Statement,
+ N_Compilation_Unit_Aux,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body,
+ N_Package_Specification);
end Has_Declarations;
-------------------------------------------
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
- Iface : Entity_Id;
- Typ : Entity_Id;
+ Iface : Entity_Id := Base_Type (Iface_Ent);
+ Typ : Entity_Id := Base_Type (Typ_Ent);
begin
- if Is_Class_Wide_Type (Typ_Ent) then
- Typ := Etype (Typ_Ent);
- else
- Typ := Typ_Ent;
- end if;
-
- if Is_Class_Wide_Type (Iface_Ent) then
- Iface := Etype (Iface_Ent);
- else
- Iface := Iface_Ent;
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
+ if Is_Class_Wide_Type (Iface) then
+ Iface := Root_Type (Iface);
+ end if;
+
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);
begin
Save_Interps (N, New_Prefix);
+
+ -- Check if the node relocation requires readjustment of some SCIL
+ -- dispatching node.
+
+ if Generate_SCIL
+ and then Nkind (N) = N_Function_Call
+ then
+ Adjust_SCIL_Node (N, New_Prefix);
+ end if;
+
Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));
if Is_Overloaded (New_Prefix) then
- -- The deference is also overloaded, and its interpretations are the
- -- designated types of the interpretations of the original node.
+ -- The dereference is also overloaded, and its interpretations are
+ -- the designated types of the interpretations of the original node.
Set_Etype (N, Any_Type);
and then E = Base_Type (E);
end Is_AAMP_Float;
+ -----------------------------
+ -- Is_Actual_Out_Parameter --
+ -----------------------------
+
+ function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal)
+ and then Ekind (Formal) = E_Out_Parameter;
+ end Is_Actual_Out_Parameter;
+
-------------------------
-- Is_Actual_Parameter --
-------------------------
end if;
end Is_Fully_Initialized_Variant;
+ ------------
+ -- Is_LHS --
+ ------------
+
+ -- We seem to have a lot of overlapping functions that do similar things
+ -- (testing for left hand sides or lvalues???). Anyway, since this one is
+ -- purely syntactic, it should be in Sem_Aux I would think???
+
+ function Is_LHS (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+ begin
+ return Nkind (P) = N_Assignment_Statement
+ and then Name (P) = N;
+ end Is_LHS;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
function Is_Value_Type (T : Entity_Id) return Boolean is
begin
return VM_Target = CLI_Target
+ and then Nkind (T) in N_Has_Chars
and then Chars (T) /= No_Name
and then Get_Name_String (Chars (T)) = "valuetype";
end Is_Value_Type;
-----------------
+ -- Is_Delegate --
+ -----------------
+
+ function Is_Delegate (T : Entity_Id) return Boolean is
+ Desig_Type : Entity_Id;
+
+ begin
+ if VM_Target /= CLI_Target then
+ return False;
+ end if;
+
+ -- Access-to-subprograms are delegates in CIL
+
+ if Ekind (T) = E_Access_Subprogram_Type then
+ return True;
+ end if;
+
+ if Ekind (T) not in Access_Kind then
+
+ -- A delegate is a managed pointer. If no designated type is defined
+ -- it means that it's not a delegate.
+
+ return False;
+ end if;
+
+ Desig_Type := Etype (Directly_Designated_Type (T));
+
+ if not Is_Tagged_Type (Desig_Type) then
+ return False;
+ end if;
+
+ -- Test if the type is inherited from [mscorlib]System.Delegate
+
+ while Etype (Desig_Type) /= Desig_Type loop
+ if Chars (Scope (Desig_Type)) /= No_Name
+ and then Is_Imported (Scope (Desig_Type))
+ and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
+ then
+ return True;
+ end if;
+
+ Desig_Type := Etype (Desig_Type);
+ end loop;
+
+ return False;
+ end Is_Delegate;
+
+ -----------------
-- Is_Variable --
-----------------
function Is_Variable (N : Node_Id) return Boolean is
Orig_Node : constant Node_Id := Original_Node (N);
- -- We do the test on the original node, since this is basically a
- -- test of syntactic categories, so it must not be disturbed by
- -- whatever rewriting might have occurred. For example, an aggregate,
- -- which is certainly NOT a variable, could be turned into a variable
- -- by expansion.
+ -- We do the test on the original node, since this is basically a test
+ -- of syntactic categories, so it must not be disturbed by whatever
+ -- rewriting might have occurred. For example, an aggregate, which is
+ -- certainly NOT a variable, could be turned into a variable by
+ -- expansion.
function In_Protected_Function (E : Entity_Id) return Boolean;
-- Within a protected function, the private components of the
end if;
end Is_Variable;
+ ---------------------------
+ -- Is_Visibly_Controlled --
+ ---------------------------
+
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+ Root : constant Entity_Id := Root_Type (T);
+ begin
+ return Chars (Scope (Root)) = Name_Finalization
+ and then Chars (Scope (Scope (Root))) = Name_Ada
+ and then Scope (Scope (Scope (Root))) = Standard_Standard;
+ end Is_Visibly_Controlled;
+
------------------------
-- Is_Volatile_Object --
------------------------
Last_Assignment_Only : Boolean := False)
is
begin
+ -- ??? do we have to worry about clearing cached checks?
+
if Is_Assignable (Ent) then
Set_Last_Assignment (Ent, Empty);
end if;
- if not Last_Assignment_Only and then Is_Object (Ent) then
- Kill_Checks (Ent);
- Set_Current_Value (Ent, Empty);
+ if Is_Object (Ent) then
+ if not Last_Assignment_Only then
+ Kill_Checks (Ent);
+ Set_Current_Value (Ent, Empty);
- if not Can_Never_Be_Null (Ent) then
- Set_Is_Known_Non_Null (Ent, False);
- end if;
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+
+ Set_Is_Known_Null (Ent, False);
- Set_Is_Known_Null (Ent, False);
+ -- Reset Is_Known_Valid unless type is always valid, or if we have
+ -- a loop parameter (loop parameters are always valid, since their
+ -- bounds are defined by the bounds given in the loop header).
+
+ if not Is_Known_Valid (Etype (Ent))
+ and then Ekind (Ent) /= E_Loop_Parameter
+ then
+ Set_Is_Known_Valid (Ent, False);
+ end if;
+ end if;
end if;
end Kill_Current_Values;
return False;
end if;
- -- For a selected component A.B, A is certainly an Lvalue if A.B is
- -- an Lvalue. B is a little interesting, if we have A.B:=3, there is
- -- some discussion as to whether B is an Lvalue or not, we choose to
- -- say it is. Note however that A is not an Lvalue if it is of an
- -- access type since this is an implicit dereference.
+ -- For a selected component A.B, A is certainly an lvalue if A.B is.
+ -- B is a little interesting, if we have A.B := 3, there is some
+ -- discussion as to whether B is an lvalue or not, we choose to say
+ -- it is. Note however that A is not an lvalue if it is of an access
+ -- type since this is an implicit dereference.
when N_Selected_Component =>
if N = Prefix (P)
end if;
-- For an indexed component or slice, the index or slice bounds is
- -- never an Lvalue. The prefix is an lvalue if the indexed component
- -- or slice is an Lvalue, except if it is an access type, where we
+ -- never an lvalue. The prefix is an lvalue if the indexed component
+ -- or slice is an lvalue, except if it is an access type, where we
-- have an implicit dereference.
when N_Indexed_Component =>
return May_Be_Lvalue (P);
end if;
- -- Prefix of a reference is an Lvalue if the reference is an Lvalue
+ -- Prefix of a reference is an lvalue if the reference is an lvalue
when N_Reference =>
return May_Be_Lvalue (P);
- -- Prefix of explicit dereference is never an Lvalue
+ -- Prefix of explicit dereference is never an lvalue
when N_Explicit_Dereference =>
return False;
- -- Function call arguments are never Lvalues
+ -- Function call arguments are never lvalues
when N_Function_Call =>
return False;
when N_Object_Renaming_Declaration =>
return True;
- -- All other references are definitely not Lvalues
+ -- All other references are definitely not lvalues
when others =>
return False;
P := Parent (N);
while Present (P) loop
- if Nkind (P) = N_If_Statement
+ if Nkind (P) = N_If_Statement
or else Nkind (P) = N_Case_Statement
- or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P))
- or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P))
+ or else (Nkind (P) in N_Short_Circuit
+ and then Desc = Right_Opnd (P))
+ or else (Nkind (P) = N_Conditional_Expression
+ and then Desc /= First (Expressions (P)))
or else Nkind (P) = N_Exception_Handler
or else Nkind (P) = N_Selective_Accept
or else Nkind (P) = N_Conditional_Entry_Call
end loop;
end;
+ if Ekind (T) = E_Class_Wide_Subtype then
+ Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
+ end if;
+
elsif Is_Array_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
begin
-- Deal with indexed or selected component where prefix is modified
- if Nkind (N) = N_Indexed_Component
- or else
- Nkind (N) = N_Selected_Component
- then
+ if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is
Error_Msg_NE ("\\found}!", Expr, Found_Type);
end if;
+ -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
+ -- of the same modular type, and (M1 and M2) = 0 was intended.
+
+ if Expec_Type = Standard_Boolean
+ and then Is_Modular_Integer_Type (Found_Type)
+ and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
+ and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
+ then
+ declare
+ Op : constant Node_Id := Right_Opnd (Parent (Expr));
+ L : constant Node_Id := Left_Opnd (Op);
+ R : constant Node_Id := Right_Opnd (Op);
+ begin
+ -- The case for the message is when the left operand of the
+ -- comparison is the same modular type, or when it is an
+ -- integer literal (or other universal integer expression),
+ -- which would have been typed as the modular type if the
+ -- parens had been there.
+
+ if (Etype (L) = Found_Type
+ or else
+ Etype (L) = Universal_Integer)
+ and then Is_Integer_Type (Etype (R))
+ then
+ Error_Msg_N
+ ("\\possible missing parens for modular operation", Expr);
+ end if;
+ end;
+ end if;
+
+ -- Reset error message qualification indication
+
Error_Msg_Qual_Level := 0;
end if;
end Wrong_Type;
OSDN Git Service
