summaryrefslogtreecommitdiff
path: root/gcc/ada/sem_res.adb
diff options
context:
space:
mode:
authorbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2008-04-14 16:23:18 +0000
committerbstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>2008-04-14 16:23:18 +0000
commitab2ba306f09948ff09fef49f3592d714c38b2d93 (patch)
treeb12d13d305b3e049e0907c34ad5d505ce04fa415 /gcc/ada/sem_res.adb
parenta39fe8c82fd895251538269b679047bd6fc98ac5 (diff)
downloadgcc-ab2ba306f09948ff09fef49f3592d714c38b2d93.tar.gz
2008-04-14 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk r134275 stilly buggy for libgcc muldi3: internal compiler error: in execute_ipa_pass_list, at passes.c:1235 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@134279 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_res.adb')
-rw-r--r--gcc/ada/sem_res.adb615
1 files changed, 411 insertions, 204 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 9e8687daad6..cfa1a8cd0d7 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -68,6 +68,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -395,9 +396,9 @@ package body Sem_Res is
D : Node_Id;
begin
- -- Any use in a default expression is legal
+ -- Any use in a a spec-expression is legal
- if In_Default_Expression then
+ if In_Spec_Expression then
null;
elsif Nkind (PN) = N_Range then
@@ -434,10 +435,9 @@ package body Sem_Res is
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Definition
- or else
- Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ Nkind_In (Parent (Parent (P)), N_Component_Definition,
+ N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
@@ -554,8 +554,8 @@ package body Sem_Res is
-- Legal case is in index or discriminant constraint
- elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
- or else Nkind (PN) = N_Discriminant_Association
+ elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
+ N_Discriminant_Association)
then
if Paren_Count (N) > 0 then
Error_Msg_N
@@ -576,9 +576,9 @@ package body Sem_Res is
else
D := PN;
P := Parent (PN);
- while Nkind (P) /= N_Component_Declaration
- and then Nkind (P) /= N_Subtype_Indication
- and then Nkind (P) /= N_Entry_Declaration
+ while not Nkind_In (P, N_Component_Declaration,
+ N_Subtype_Indication,
+ N_Entry_Declaration)
loop
D := P;
P := Parent (P);
@@ -591,10 +591,8 @@ package body Sem_Res is
-- is of course a double fault.
if (Nkind (P) = N_Subtype_Indication
- and then
- (Nkind (Parent (P)) = N_Component_Definition
- or else
- Nkind (Parent (P)) = N_Derived_Type_Definition)
+ and then Nkind_In (Parent (P), N_Component_Definition,
+ N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
@@ -753,11 +751,10 @@ package body Sem_Res is
loop
P := Parent (C);
exit when Nkind (P) = N_Subprogram_Body;
-
- if Nkind (P) = N_Or_Else or else
- Nkind (P) = N_And_Then or else
- Nkind (P) = N_If_Statement or else
- Nkind (P) = N_Case_Statement
+ if Nkind_In (P, N_Or_Else,
+ N_And_Then,
+ N_If_Statement,
+ N_Case_Statement)
then
return False;
@@ -831,7 +828,7 @@ package body Sem_Res is
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
-- use of the secondary stack. If T is a record type, this is true
- -- if the expression for some component uses the secondary stack, eg.
+ -- if the expression for some component uses the secondary stack, e.g.
-- through a call to a function that returns an unconstrained value.
-- False if T is controlled, because cleanups occur elsewhere.
@@ -963,25 +960,24 @@ package body Sem_Res is
Require_Entity (N);
end if;
- -- If the context expects a value, and the name is a procedure,
- -- this is most likely a missing 'Access. Do not try to resolve
- -- the parameterless call, error will be caught when the outer
- -- call is analyzed.
+ -- If the context expects a value, and the name is a procedure, this is
+ -- most likely a missing 'Access. Don't try to resolve the parameterless
+ -- call, error will be caught when the outer call is analyzed.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Procedure
and then not Is_Overloaded (N)
and then
- (Nkind (Parent (N)) = N_Parameter_Association
- or else Nkind (Parent (N)) = N_Function_Call
- or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ Nkind_In (Parent (N), N_Parameter_Association,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
then
return;
end if;
- -- Rewrite as call if overloadable entity that is (or could be, in
- -- the overloaded case) a function call. If we know for sure that
- -- the entity is an enumeration literal, we do not rewrite it.
+ -- Rewrite as call if overloadable entity that is (or could be, in the
+ -- overloaded case) a function call. If we know for sure that the entity
+ -- is an enumeration literal, we do not rewrite it.
if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N))
@@ -989,7 +985,7 @@ package body Sem_Res is
or else Is_Overloaded (N)))
-- Rewrite as call if it is an explicit deference of an expression of
- -- a subprogram access type, and the suprogram type is not that of a
+ -- a subprogram access type, and the subprogram type is not that of a
-- procedure or entry.
or else
@@ -1386,7 +1382,19 @@ package body Sem_Res is
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
- Rewrite (N, Op_Node);
+
+ -- Do rewrite setting Comes_From_Source on the result if the original
+ -- call came from source. Although it is not strictly the case that the
+ -- operator as such comes from the source, logically it corresponds
+ -- exactly to the function call in the source, so it should be marked
+ -- this way (e.g. to make sure that validity checks work fine).
+
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+ begin
+ Rewrite (N, Op_Node);
+ Set_Comes_From_Source (N, CS);
+ end;
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
@@ -1487,11 +1495,11 @@ package body Sem_Res is
return Kind;
end Operator_Kind;
- -----------------------------
- -- Pre_Analyze_And_Resolve --
- -----------------------------
+ ----------------------------
+ -- Preanalyze_And_Resolve --
+ ----------------------------
- procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
@@ -1506,11 +1514,11 @@ package body Sem_Res is
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
-- Version without context type
- procedure Pre_Analyze_And_Resolve (N : Node_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
@@ -1522,7 +1530,7 @@ package body Sem_Res is
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
----------------------------------
-- Replace_Actual_Discriminants --
@@ -1647,6 +1655,7 @@ package body Sem_Res is
Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
+
elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ)
then
@@ -1909,8 +1918,8 @@ package body Sem_Res is
-- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error.
- if Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement
+ if Nkind_In (N, N_Function_Call,
+ N_Procedure_Call_Statement)
then
declare
A : Node_Id;
@@ -2079,14 +2088,14 @@ package body Sem_Res is
-- 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
- or else Nkind (N) = N_And_Then
- or else Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Or_Else
- or else Nkind (N) = N_Range
- or else Nkind (N) = N_Selected_Component
- or else Nkind (N) = N_Slice
+ elsif Nkind_In (N, N_Explicit_Dereference,
+ N_Attribute_Reference,
+ N_And_Then,
+ N_Indexed_Component,
+ N_Or_Else,
+ N_Range,
+ N_Selected_Component,
+ N_Slice)
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
@@ -2094,8 +2103,7 @@ package body Sem_Res is
-- 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)
+ elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
and then (Is_Entity_Name (Name (N))
or else Nkind (Name (N)) = N_Operator_Symbol)
then
@@ -2379,7 +2387,7 @@ package body Sem_Res is
end if;
end if;
- -- A user-defined operator is tranformed into a function call at
+ -- A user-defined operator is transformed into a function call at
-- this point, so that further processing knows that operators are
-- really operators (i.e. are predefined operators). User-defined
-- operators that are intrinsic are just renamings of the predefined
@@ -2398,8 +2406,8 @@ package body Sem_Res is
elsif Present (Alias (Entity (N)))
and then
- Nkind (Parent (Parent (Entity (N))))
- = N_Subprogram_Renaming_Declaration
+ Nkind (Parent (Parent (Entity (N)))) =
+ N_Subprogram_Renaming_Declaration
then
Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
@@ -2613,6 +2621,11 @@ package body Sem_Res is
Prev : Node_Id := Empty;
Orig_A : Node_Id;
+ procedure Check_Argument_Order;
+ -- Performs a check for the case where the actuals are all simple
+ -- identifiers that correspond to the formal names, but in the wrong
+ -- order, which is considered suspicious and cause for a warning.
+
procedure Check_Prefixed_Call;
-- If the original node is an overloaded call in prefix notation,
-- insert an 'Access or a dereference as needed over the first actual.
@@ -2630,6 +2643,119 @@ package body Sem_Res is
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
+ --------------------------
+ -- Check_Argument_Order --
+ --------------------------
+
+ procedure Check_Argument_Order is
+ begin
+ -- Nothing to do if no parameters, or original node is neither a
+ -- function call nor a procedure call statement (happens in the
+ -- operator-transformed-to-function call case), or the call does
+ -- not come from source, or this warning is off.
+
+ if not Warn_On_Parameter_Order
+ or else
+ No (Parameter_Associations (N))
+ or else
+ not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
+ N_Function_Call)
+ or else
+ not Comes_From_Source (N)
+ then
+ return;
+ end if;
+
+ declare
+ Nargs : constant Nat := List_Length (Parameter_Associations (N));
+
+ begin
+ -- Nothing to do if only one parameter
+
+ if Nargs < 2 then
+ return;
+ end if;
+
+ -- Here if at least two arguments
+
+ declare
+ Actuals : array (1 .. Nargs) of Node_Id;
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ Wrong_Order : Boolean := False;
+ -- Set True if an out of order case is found
+
+ begin
+ -- Collect identifier names of actuals, fail if any actual is
+ -- not a simple identifier, and record max length of name.
+
+ Actual := First (Parameter_Associations (N));
+ for J in Actuals'Range loop
+ if Nkind (Actual) /= N_Identifier then
+ return;
+ else
+ Actuals (J) := Actual;
+ Next (Actual);
+ end if;
+ end loop;
+
+ -- If we got this far, all actuals are identifiers and the list
+ -- of their names is stored in the Actuals array.
+
+ Formal := First_Formal (Nam);
+ for J in Actuals'Range loop
+
+ -- If we ran out of formals, that's odd, probably an error
+ -- which will be detected elsewhere, but abandon the search.
+
+ if No (Formal) then
+ return;
+ end if;
+
+ -- If name matches and is in order OK
+
+ if Chars (Formal) = Chars (Actuals (J)) then
+ null;
+
+ else
+ -- If no match, see if it is elsewhere in list and if so
+ -- flag potential wrong order if type is compatible.
+
+ for K in Actuals'Range loop
+ if Chars (Formal) = Chars (Actuals (K))
+ and then
+ Has_Compatible_Type (Actuals (K), Etype (Formal))
+ then
+ Wrong_Order := True;
+ goto Continue;
+ end if;
+ end loop;
+
+ -- No match
+
+ return;
+ end if;
+
+ <<Continue>> Next_Formal (Formal);
+ end loop;
+
+ -- If Formals left over, also probably an error, skip warning
+
+ if Present (Formal) then
+ return;
+ end if;
+
+ -- Here we give the warning if something was out of order
+
+ if Wrong_Order then
+ Error_Msg_N
+ ("actuals for this call may be in wrong order?", N);
+ end if;
+ end;
+ end;
+ end Check_Argument_Order;
+
-------------------------
-- Check_Prefixed_Call --
-------------------------
@@ -2743,7 +2869,7 @@ package body Sem_Res is
Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
- -- anomalies: the subtype was first built in the suprogram
+ -- anomalies: the subtype was first built in the subprogram
-- declaration, and the current call may be nested.
if Nkind (Actval) = N_Aggregate
@@ -2866,6 +2992,8 @@ package body Sem_Res is
-- Start of processing for Resolve_Actuals
begin
+ Check_Argument_Order;
+
if Present (First_Actual (N)) then
Check_Prefixed_Call;
end if;
@@ -2889,7 +3017,7 @@ package body Sem_Res is
-- Case where actual is present
- -- If the actual is an entity, generate a reference to it now. We
+ -- If the actual is an entity, generate a reference to it now. We
-- do this before the actual is resolved, because a formal of some
-- protected subprogram, or a task discriminant, will be rewritten
-- during expansion, and the reference to the source entity may
@@ -2906,7 +3034,6 @@ package body Sem_Res is
and then Ekind (F) /= E_In_Parameter
then
Generate_Reference (Orig_A, A, 'm');
-
elsif not Is_Overloaded (A) then
Generate_Reference (Orig_A, A);
end if;
@@ -2918,6 +3045,14 @@ package body Sem_Res is
or else
Chars (Selector_Name (Parent (A))) = Chars (F))
then
+ -- If style checking mode on, check match of formal name
+
+ if Style_Check then
+ if Nkind (Parent (A)) = N_Parameter_Association then
+ Check_Identifier (Selector_Name (Parent (A)), F);
+ end if;
+ end if;
+
-- If the formal is Out or In_Out, do not resolve and expand the
-- conversion, because it is subsequently expanded into explicit
-- temporaries and assignments. However, the object of the
@@ -2941,32 +3076,51 @@ package body Sem_Res is
if Has_Aliased_Components (Etype (Expression (A)))
/= Has_Aliased_Components (Etype (F))
then
- if Ada_Version < Ada_05 then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
- -- Ada 2005: rule is relaxed (see AI-363)
+ -- In a view conversion, the conversion must be legal in
+ -- both directions, and thus both component types must be
+ -- aliased, or neither (4.6 (8)).
- elsif Has_Aliased_Components (Etype (F))
- and then
- not Has_Aliased_Components (Etype (Expression (A)))
+ -- The additional rule 4.6 (24.9.2) seems unduly
+ -- restrictive: the privacy requirement should not
+ -- apply to generic types, and should be checked in
+ -- an instance. ARG query is in order.
+
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ elsif
+ not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ then
+ if Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (Etype (Expression (A)))
then
Error_Msg_N
- ("view conversion operand must have aliased " &
- "components", N);
- Error_Msg_N
- ("\since target type has aliased components", N);
+ ("view conversion between unrelated by reference " &
+ "array types not allowed (\'A'I-00246)", A);
+ else
+ declare
+ Comp_Type : constant Entity_Id :=
+ Component_Type
+ (Etype (Expression (A)));
+ begin
+ if Comes_From_Source (A)
+ and then Ada_Version >= Ada_05
+ and then
+ ((Is_Private_Type (Comp_Type)
+ and then not Is_Generic_Type (Comp_Type))
+ or else Is_Tagged_Type (Comp_Type)
+ or else Is_Volatile (Comp_Type))
+ then
+ Error_Msg_N
+ ("component type of a view conversion cannot"
+ & " be private, tagged, or volatile"
+ & " (RM 4.6 (24))",
+ Expression (A));
+ end if;
+ end;
end if;
-
- elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
- and then
- (Is_By_Reference_Type (Etype (F))
- or else Is_By_Reference_Type (Etype (Expression (A))))
- then
- Error_Msg_N
- ("view conversion between unrelated by reference " &
- "array types not allowed (\'A'I-00246)", A);
end if;
end if;
@@ -3024,14 +3178,15 @@ package body Sem_Res is
declare
DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F)));
+
New_Itype : Entity_Id;
+
begin
if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT)
then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
- Set_Etype (New_Itype, Etype (A));
- Init_Size_Align (New_Itype);
+ Set_Etype (New_Itype, Etype (A));
Set_Directly_Designated_Type (New_Itype,
Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
@@ -3043,8 +3198,7 @@ package body Sem_Res is
-- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct.
- if (Is_Controlled (DDT)
- or else Has_Task (DDT))
+ if (Is_Controlled (DDT) or else Has_Task (DDT))
and then Expander_Active
then
Establish_Transient_Scope (A, False);
@@ -3056,9 +3210,13 @@ package body Sem_Res is
-- a tagged synchronized type, declared outside of the type.
-- In this case the controlling actual must be converted to
-- its corresponding record type, which is the formal type.
+ -- The actual may be a subtype, either because of a constraint
+ -- or because it is a generic actual, so use base type to
+ -- locate concurrent type.
if Is_Concurrent_Type (Etype (A))
- and then Etype (F) = Corresponding_Record_Type (Etype (A))
+ and then Etype (F) =
+ Corresponding_Record_Type (Base_Type (Etype (A)))
then
Rewrite (A,
Unchecked_Convert_To
@@ -3130,14 +3288,14 @@ package body Sem_Res is
if Ekind (F) /= E_In_Parameter then
-- For an Out parameter, check for useless assignment. Note
- -- that we can't set Last_Assignment this early, because we
- -- may kill current values in Resolve_Call, and that call
- -- would clobber the Last_Assignment field.
+ -- that we can't set Last_Assignment this early, because we may
+ -- kill current values in Resolve_Call, and that call would
+ -- clobber the Last_Assignment field.
- -- Note: call Warn_On_Useless_Assignment before doing the
- -- check below for Is_OK_Variable_For_Out_Formal so that the
- -- setting of Referenced_As_LHS/Referenced_As_Out_Formal
- -- properly reflects the last assignment, not this one!
+ -- Note: call Warn_On_Useless_Assignment before doing the check
+ -- below for Is_OK_Variable_For_Out_Formal so that the setting
+ -- of Referenced_As_LHS/Referenced_As_Out_Formal properly
+ -- reflects the last assignment, not this one!
if Ekind (F) = E_Out_Parameter then
if Warn_On_Modified_As_Out_Parameter (F)
@@ -3258,8 +3416,8 @@ package body Sem_Res is
end if;
-- An actual associated with an access parameter is implicitly
- -- converted to the anonymous access type of the formal and
- -- must satisfy the legality checks for access conversions.
+ -- converted to the anonymous access type of the formal and must
+ -- satisfy the legality checks for access conversions.
if Ekind (F_Typ) = E_Anonymous_Access_Type then
if not Valid_Conversion (A, F_Typ, A) then
@@ -3427,7 +3585,7 @@ package body Sem_Res is
-- 1) Analyze Top_Record
-- 2) Analyze Level_1_Coextension
-- 3) Analyze Level_2_Coextension
- -- 4) Resolve Level_2_Coextnesion. The allocator is marked as a
+ -- 4) Resolve Level_2_Coextension. The allocator is marked as a
-- coextension.
-- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is
-- generated to capture the allocated object. Temp_1 is attached
@@ -3500,8 +3658,7 @@ package body Sem_Res is
function In_Dispatching_Context return Boolean is
Par : constant Node_Id := Parent (N);
begin
- return (Nkind (Par) = N_Function_Call
- or else Nkind (Par) = N_Procedure_Call_Statement)
+ return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par))
and then Is_Dispatching_Operation (Entity (Name (Par)));
end In_Dispatching_Context;
@@ -3518,7 +3675,7 @@ package body Sem_Res is
function Process_Allocator (Nod : Node_Id) return Traverse_Result;
-- Recognize an allocator or a rewritten allocator node and add it
- -- allong with its nested coextensions to the list of Root.
+ -- along with its nested coextensions to the list of Root.
---------------
-- Copy_List --
@@ -3676,7 +3833,7 @@ package body Sem_Res is
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
-- expression used to constrain an access discriminant cannot be
- -- deeper than the type of the allocator (in constrast to access
+ -- deeper than the type of the allocator (in contrast to access
-- parameters, where the level of the actual can be arbitrary).
-- We can't use Valid_Conversion to perform this check because
@@ -3691,10 +3848,7 @@ package body Sem_Res is
Aggr := Original_Node (Expression (E));
if Has_Discriminants (Subtyp)
- and then
- (Nkind (Aggr) = N_Aggregate
- or else
- Nkind (Aggr) = N_Extension_Aggregate)
+ and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
then
Discrim := First_Discriminant (Base_Type (Subtyp));
@@ -3758,7 +3912,7 @@ package body Sem_Res is
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
-- expression used to constrain an access discriminant cannot be
- -- deeper than the type of the allocator (in constrast to access
+ -- deeper than the type of the allocator (in contrast to access
-- parameters, where the level of the actual can be arbitrary).
-- We can't use Valid_Conversion to perform this check because
-- in general the type of the allocator is unrelated to the type
@@ -3938,18 +4092,18 @@ package body Sem_Res is
-- N is the expression after "delta" in a fixed_point_definition;
-- see RM-3.5.9(6):
- return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition
- or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition
+ return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
+ N_Decimal_Fixed_Point_Definition,
-- N is one of the bounds in a real_range_specification;
-- see RM-3.5.7(5):
- or else Nkind (Parent (N)) = N_Real_Range_Specification
+ N_Real_Range_Specification,
-- N is the expression of a delta_constraint;
-- see RM-J.3(3):
- or else Nkind (Parent (N)) = N_Delta_Constraint;
+ N_Delta_Constraint);
end Expected_Type_Is_Any_Real;
-----------------------------
@@ -4143,8 +4297,7 @@ package body Sem_Res is
-- conversion to a specific fixed-point type (instead the expander
-- takes care of the case).
- elsif (B_Typ = Universal_Integer
- or else B_Typ = Universal_Real)
+ elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
@@ -4153,15 +4306,14 @@ package body Sem_Res is
Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real
- or else Etype (N) = Universal_Fixed
- or else (Etype (N) = Any_Fixed
- and then Is_Fixed_Point_Type (B_Typ))
- or else (Is_Fixed_Point_Type (B_Typ)
- and then (Is_Integer_Or_Universal (L)
- or else
- Is_Integer_Or_Universal (R))))
- and then (Nkind (N) = N_Op_Multiply or else
- Nkind (N) = N_Op_Divide)
+ or else Etype (N) = Universal_Fixed
+ or else (Etype (N) = Any_Fixed
+ and then Is_Fixed_Point_Type (B_Typ))
+ or else (Is_Fixed_Point_Type (B_Typ)
+ and then (Is_Integer_Or_Universal (L)
+ or else
+ Is_Integer_Or_Universal (R))))
+ and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
then
if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ);
@@ -4189,38 +4341,36 @@ package body Sem_Res is
Set_Mixed_Mode_Operand (R, TL);
end if;
- -- Check the rule in RM05-4.5.5(19.1/2) disallowing the
- -- universal_fixed multiplying operators from being used when the
- -- expected type is also universal_fixed. Note that B_Typ will be
- -- Universal_Fixed in some cases where the expected type is actually
- -- Any_Real; Expected_Type_Is_Any_Real takes care of that case.
+ -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
+ -- multiplying operators from being used when the expected type is
+ -- also universal_fixed. Note that B_Typ will be Universal_Fixed in
+ -- some cases where the expected type is actually Any_Real;
+ -- Expected_Type_Is_Any_Real takes care of that case.
if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed
then
if B_Typ = Universal_Fixed
and then not Expected_Type_Is_Any_Real (N)
- and then Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then not Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
- Error_Msg_N
- ("type cannot be determined from context!", N);
- Error_Msg_N
- ("\explicit conversion to result type required", N);
+ Error_Msg_N ("type cannot be determined from context!", N);
+ Error_Msg_N ("\explicit conversion to result type required", N);
Set_Etype (L, Any_Type);
Set_Etype (R, Any_Type);
else
if Ada_Version = Ada_83
- and then Etype (N) = Universal_Fixed
- and then Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then Etype (N) = Universal_Fixed
+ and then not
+ Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
Error_Msg_N
- ("(Ada 83) fixed-point operation " &
- "needs explicit conversion",
- N);
+ ("(Ada 83) fixed-point operation "
+ & "needs explicit conversion", N);
end if;
-- The expected type is "any real type" in contexts like
@@ -4239,8 +4389,7 @@ package body Sem_Res is
and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal
- or else
- Is_Integer_Or_Universal (R))
+ or else Is_Integer_Or_Universal (R))
then
Set_Etype (N, B_Typ);
@@ -4254,7 +4403,8 @@ package body Sem_Res is
else
if (TL = Universal_Integer or else TL = Universal_Real)
- and then (TR = Universal_Integer or else TR = Universal_Real)
+ and then
+ (TR = Universal_Integer or else TR = Universal_Real)
then
Check_For_Visible_Operator (N, B_Typ);
end if;
@@ -4263,9 +4413,7 @@ package body Sem_Res is
-- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration).
- if B_Typ = Universal_Fixed
- and then Etype (L) = Universal_Fixed
- then
+ if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
T := Unique_Fixed_Point_Type (N);
if T = Any_Type then
@@ -4306,19 +4454,17 @@ package body Sem_Res is
-- Give warning if explicit division by zero
- if (Nkind (N) = N_Op_Divide
- or else Nkind (N) = N_Op_Rem
- or else Nkind (N) = N_Op_Mod)
+ if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
Rop := Right_Opnd (N);
if Compile_Time_Known_Value (Rop)
and then ((Is_Integer_Type (Etype (Rop))
- and then Expr_Value (Rop) = Uint_0)
+ and then Expr_Value (Rop) = Uint_0)
or else
(Is_Real_Type (Etype (Rop))
- and then Expr_Value_R (Rop) = Ureal_0))
+ and then Expr_Value_R (Rop) = Ureal_0))
then
-- Specialize the warning message according to the operation
@@ -4351,6 +4497,38 @@ package body Sem_Res is
Activate_Division_Check (N);
end if;
end if;
+
+ -- If Restriction No_Implicit_Conditionals is active, then it is
+ -- violated if either operand can be negative for mod, or for rem
+ -- if both operands can be negative.
+
+ if Restrictions.Set (No_Implicit_Conditionals)
+ and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
+ then
+ declare
+ Lo : Uint;
+ Hi : Uint;
+ OK : Boolean;
+
+ LNeg : Boolean;
+ RNeg : Boolean;
+ -- Set if corresponding operand might be negative
+
+ begin
+ Determine_Range (Left_Opnd (N), OK, Lo, Hi);
+ LNeg := (not OK) or else Lo < 0;
+
+ Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+ RNeg := (not OK) or else Lo < 0;
+
+ if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
+ or else
+ (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
+ then
+ Check_Restriction (No_Implicit_Conditionals, N);
+ end if;
+ end;
+ end if;
end if;
Check_Unset_Reference (L);
@@ -4426,8 +4604,7 @@ package body Sem_Res is
-- operations use the same circuitry because the name in the call
-- can be an arbitrary expression with special resolution rules.
- elsif Nkind (Subp) = N_Selected_Component
- or else Nkind (Subp) = N_Indexed_Component
+ elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry)
then
@@ -4474,11 +4651,16 @@ package body Sem_Res is
P := N;
loop
P := Parent (P);
- exit when No (P);
+
+ -- Exclude calls that occur within the default of a formal
+ -- parameter of the entry, since those are evaluated outside
+ -- of the body.
+
+ exit when No (P) or else Nkind (P) = N_Parameter_Specification;
if Nkind (P) = N_Entry_Body
or else (Nkind (P) = N_Subprogram_Body
- and then Is_Entry_Barrier_Function (P))
+ and then Is_Entry_Barrier_Function (P))
then
Rtype := Etype (N);
Error_Msg_NE
@@ -4540,7 +4722,7 @@ package body Sem_Res is
Error_Msg_N ("\cannot call operation that may modify it", N);
end if;
- -- Freeze the subprogram name if not in default expression. Note that we
+ -- Freeze the subprogram name if not in a spec-expression. Note that we
-- freeze procedure calls as well as function calls. Procedure calls are
-- not frozen according to the rules (RM 13.14(14)) because it is
-- impossible to have a procedure call to a non-frozen procedure in pure
@@ -4548,7 +4730,7 @@ package body Sem_Res is
-- needs extending because we can generate procedure calls that need
-- freezing.
- if Is_Entity_Name (Subp) and then not In_Default_Expression then
+ if Is_Entity_Name (Subp) and then not In_Spec_Expression then
Freeze_Expression (Subp);
end if;
@@ -4803,12 +4985,14 @@ package body Sem_Res is
-- If the subprogram is marked Inline_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary
- -- stack.
+ -- stack. However, inlining will only take place if the body to inline
+ -- is already present. It may not be available if e.g. the subprogram is
+ -- declared in a child instance.
if Is_Inlined (Nam)
- and then Present (First_Rep_Item (Nam))
- and then Nkind (First_Rep_Item (Nam)) = N_Pragma
- and then Pragma_Name (First_Rep_Item (Nam)) = Name_Inline_Always
+ and then Has_Pragma_Inline_Always (Nam)
+ and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
then
null;
@@ -4883,8 +5067,14 @@ package body Sem_Res is
-- way we still take advantage of the current value information while
-- scanning the actuals.
- if (not Is_Library_Level_Entity (Nam)
- or else Suppress_Value_Tracking_On_Call (Current_Scope))
+ -- We suppress killing values if we are processing the nodes associated
+ -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
+ -- type kills all the values as part of analyzing the code that
+ -- initializes the dispatch tables.
+
+ if Inside_Freezing_Actions = 0
+ and then (not Is_Library_Level_Entity (Nam)
+ or else Suppress_Value_Tracking_On_Call (Current_Scope))
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
@@ -5291,7 +5481,7 @@ package body Sem_Res is
and then Comes_From_Source (E)
and then No (Constant_Value (E))
and then Is_Frozen (Etype (E))
- and then not In_Default_Expression
+ and then not In_Spec_Expression
and then not Is_Imported (E)
then
@@ -5852,6 +6042,7 @@ package body Sem_Res is
(Corresponding_Equality (Entity (N)))
then
Eval_Relational_Op (N);
+
elsif Nkind (N) = N_Op_Ne
and then Is_Abstract_Subprogram (Entity (N))
then
@@ -6058,7 +6249,7 @@ package body Sem_Res is
end if;
-- If name was overloaded, set component type correctly now
- -- If a misplaced call to an entry family (which has no index typs)
+ -- If a misplaced call to an entry family (which has no index types)
-- return. Error will be diagnosed from calling context.
if Is_Array_Type (Array_Type) then
@@ -6382,9 +6573,8 @@ package body Sem_Res is
-- In the common case of a call which uses an explicitly null
-- value for an access parameter, give specialized error msg
- if Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else
- Nkind (Parent (N)) = N_Function_Call
+ if Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Function_Call)
then
Error_Msg_N
("null is not allowed as argument for an access parameter", N);
@@ -6642,7 +6832,7 @@ package body Sem_Res is
B_Typ : constant Entity_Id := Base_Type (Typ);
begin
- -- Catch attempts to do fixed-point exponentation with universal
+ -- Catch attempts to do fixed-point exponentiation with universal
-- operands, which is a case where the illegality is not caught during
-- normal operator analysis.
@@ -6749,7 +6939,7 @@ package body Sem_Res is
B_Typ := Base_Type (Typ);
end if;
- -- Straigtforward case of incorrect arguments
+ -- Straightforward case of incorrect arguments
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N);
@@ -6999,7 +7189,7 @@ package body Sem_Res is
-- sequences that otherwise fail to notice the modification.
if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
end Resolve_Reference;
@@ -7223,8 +7413,8 @@ package body Sem_Res is
Resolve (L, B_Typ);
Resolve (R, B_Typ);
- -- Check for issuing warning for always False assert, this happens
- -- when assertions are turned off, in which case the pragma Assert
+ -- Check for issuing warning for always False assert/check, this happens
+ -- when assertions are turned off, in which case the pragma Assert/Check
-- was transformed into:
-- if False and then <condition> then ...
@@ -7241,6 +7431,7 @@ package body Sem_Res is
then
declare
Orig : constant Node_Id := Original_Node (Parent (N));
+
begin
if Nkind (Orig) = N_Pragma
and then Pragma_Name (Orig) = Name_Assert
@@ -7269,6 +7460,29 @@ package body Sem_Res is
Error_Msg_N ("?assertion would fail at run-time", Orig);
end if;
end;
+
+ -- Similar processing for Check pragma
+
+ elsif Nkind (Orig) = N_Pragma
+ and then Pragma_Name (Orig) = Name_Check
+ then
+ -- Don't want to warn if original condition is explicit False
+
+ declare
+ Expr : constant Node_Id :=
+ Original_Node
+ (Expression
+ (Next (First
+ (Pragma_Argument_Associations (Orig)))));
+ begin
+ if Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False
+ then
+ null;
+ else
+ Error_Msg_N ("?check would fail at run-time", Orig);
+ end if;
+ end;
end if;
end;
end if;
@@ -7477,16 +7691,17 @@ package body Sem_Res is
elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check
- and then Nkind (Original_Node (N)) /= N_Character_Literal
- and then Nkind (Original_Node (N)) /= N_Attribute_Reference
- and then Nkind (Original_Node (N)) /= N_Qualified_Expression
- and then Nkind (Original_Node (N)) /= N_Type_Conversion
+ and then not Nkind_In (Original_Node (N), N_Character_Literal,
+ N_Attribute_Reference,
+ N_Qualified_Expression,
+ N_Type_Conversion)
then
Subtype_Id := Typ;
-- Otherwise we must create a string literal subtype. Note that the
-- whole idea of string literal subtypes is simply to avoid the need
-- for building a full fledged array subtype for each literal.
+
else
Set_String_Literal_Subtype (N, Typ);
Subtype_Id := Etype (N);
@@ -7520,8 +7735,8 @@ package body Sem_Res is
elsif R_Typ = Any_Character then
return;
- -- If the type is bit-packed, then we always tranform the string literal
- -- into a full fledged aggregate.
+ -- If the type is bit-packed, then we always transform the string
+ -- literal into a full fledged aggregate.
elsif Is_Bit_Packed_Array (Typ) then
null;
@@ -7607,10 +7822,8 @@ package body Sem_Res is
-- corresponding character aggregate and let the aggregate
-- code do the checking.
- if R_Typ = Standard_Character
- or else R_Typ = Standard_Wide_Character
- or else R_Typ = Standard_Wide_Wide_Character
- then
+ if Is_Standard_Character_Type (R_Typ) then
+
-- Check for the case of full range, where we are definitely OK
if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
@@ -7730,10 +7943,10 @@ package body Sem_Res is
Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ)
- and then (Nkind (Operand) = N_Op_Multiply
- or else Nkind (Operand) = N_Op_Divide)
+ and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
and then (Etype (Right_Opnd (Operand)) = Universal_Real
- or else Etype (Left_Opnd (Operand)) = Universal_Real)
+ or else
+ Etype (Left_Opnd (Operand)) = Universal_Real)
then
-- Return if expression is ambiguous
@@ -8039,15 +8252,11 @@ package body Sem_Res is
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
+ -- parenthesized, and is a binary 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)
+ and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
then
-- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /=
@@ -8129,9 +8338,7 @@ package body Sem_Res is
-- 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)
+ if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
and then Compile_Time_Known_Value (Right_Opnd (Rorig))
and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
then
@@ -8334,7 +8541,6 @@ package body Sem_Res is
Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
- Init_Size_Align (Slice_Subtype);
Check_Compile_Time_Size (Slice_Subtype);
@@ -8349,7 +8555,9 @@ package body Sem_Res is
-- call to Check_Compile_Time_Size could be eliminated, which would
-- be nice, because then that routine could be made private to Freeze.
- if Is_Packed (Slice_Subtype) and not In_Default_Expression then
+ -- Why the test for In_Spec_Expression here ???
+
+ if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N);
end if;
@@ -8435,7 +8643,6 @@ package body Sem_Res is
Set_First_Index (Array_Subtype, Index);
Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True);
- Init_Size_Align (Array_Subtype);
Rewrite (N,
Make_Unchecked_Type_Conversion (Loc,
@@ -8573,7 +8780,6 @@ package body Sem_Res is
if Nkind (N) = N_Real_Literal then
Error_Msg_NE ("?real literal interpreted as }!", N, T1);
-
else
Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
end if;
@@ -8736,11 +8942,12 @@ package body Sem_Res is
return False;
end if;
- -- Check that component subtypes statically match
+ -- Check that component subtypes statically match. For numeric
+ -- types this means that both must be either constrained or
+ -- unconstrained. For enumeration types the bounds must match.
+ -- All of this is checked in Subtypes_Statically_Match.
- if Is_Constrained (Target_Comp_Type) /=
- Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
+ if not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
@@ -8913,7 +9120,7 @@ package body Sem_Res is
-- Also no need to check when in an instance or inlined body, because
-- the legality has been established when the template was analyzed.
-- Furthermore, numeric conversions may occur where only a private
- -- view of the operand type is visible at the instanciation point.
+ -- view of the operand type is visible at the instantiation point.
-- This results in a spurious error if we check that the operand type
-- is a numeric type.
@@ -8993,7 +9200,7 @@ package body Sem_Res is
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
- Type_Access_Level (Target_Type)
+ Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
@@ -9016,7 +9223,7 @@ package body Sem_Res is
-- The case of a reference to an access discriminant from
-- within a limited type declaration (which will appear as
-- a discriminal) is always illegal because the level of the
- -- discriminant is considered to be deeper than any (namable)
+ -- discriminant is considered to be deeper than any (nameable)
-- access type.
if Is_Entity_Name (Operand)
@@ -9102,8 +9309,8 @@ package body Sem_Res is
-- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
- and then Object_Access_Level (Operand)
- > Type_Access_Level (Target_Type)
+ and then Object_Access_Level (Operand) >
+ Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
@@ -9128,7 +9335,7 @@ package body Sem_Res is
-- The case of a reference to an access discriminant from
-- within a limited type declaration (which will appear as
-- a discriminal) is always illegal because the level of the
- -- discriminant is considered to be deeper than any (namable)
+ -- discriminant is considered to be deeper than any (nameable)
-- access type.
if Is_Entity_Name (Operand)
View Lorry Controller Status