-- Warn about the danger
Error_Msg_N
- ("creation of & object may raise Storage_Error?",
+ ("?creation of & object may raise Storage_Error!",
Scope (Disc));
<<No_Danger>>
-- for generating a stub function
- if Nkind (Parent (N)) = N_Return_Statement
+ if Nkind (Parent (N)) = N_Simple_Return_Statement
and then Same_Argument_List
then
exit when not Is_List_Member (Parent (N));
end if;
end loop;
- Error_Msg_N ("possible infinite recursion?", N);
- Error_Msg_N ("\Storage_Error may be raised at run time?", N);
+ Error_Msg_N ("!?possible infinite recursion", N);
+ Error_Msg_N ("\!?Storage_Error may be raised at run time", N);
return True;
end Check_Infinite_Recursion;
-------------
function Uses_SS (T : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Expr : Node_Id;
+ Comp : Entity_Id;
+ Expr : Node_Id;
+ Full_Type : Entity_Id := Underlying_Type (T);
begin
- if Is_Controlled (T) then
+ -- Normally we want to use the underlying type, but if it's not set
+ -- then continue with T.
+
+ if not Present (Full_Type) then
+ Full_Type := T;
+ end if;
+
+ if Is_Controlled (Full_Type) then
return False;
- elsif Is_Array_Type (T) then
- return Uses_SS (Component_Type (T));
+ elsif Is_Array_Type (Full_Type) then
+ return Uses_SS (Component_Type (Full_Type));
- elsif Is_Record_Type (T) then
- Comp := First_Component (T);
+ elsif Is_Record_Type (Full_Type) then
+ Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
- Expr := Expression (Parent (Comp));
+ -- The expression for a dynamic component may be rewritten
+ -- as a dereference, so retrieve original node.
+
+ Expr := Original_Node (Expression (Parent (Comp)));
- -- The expression for a dynamic component may be
- -- rewritten as a dereference. Retrieve original
- -- call.
+ -- Return True if the expression is a call to a function
+ -- (including an attribute function such as Image) with
+ -- a result that requires a transient scope.
- if Nkind (Original_Node (Expr)) = N_Function_Call
+ if (Nkind (Expr) = N_Function_Call
+ or else (Nkind (Expr) = N_Attribute_Reference
+ and then Present (Expressions (Expr))))
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
begin
if Is_Binary then
- if Op_Name = Name_Op_And then Kind := N_Op_And;
- elsif Op_Name = Name_Op_Or then Kind := N_Op_Or;
- elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor;
- elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq;
- elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne;
- elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt;
- elsif Op_Name = Name_Op_Le then Kind := N_Op_Le;
- elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt;
- elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge;
- elsif Op_Name = Name_Op_Add then Kind := N_Op_Add;
- elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract;
- elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat;
- elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply;
- elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide;
- elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod;
- elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem;
- elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon;
+ if Op_Name = Name_Op_And then
+ Kind := N_Op_And;
+ elsif Op_Name = Name_Op_Or then
+ Kind := N_Op_Or;
+ elsif Op_Name = Name_Op_Xor then
+ Kind := N_Op_Xor;
+ elsif Op_Name = Name_Op_Eq then
+ Kind := N_Op_Eq;
+ elsif Op_Name = Name_Op_Ne then
+ Kind := N_Op_Ne;
+ elsif Op_Name = Name_Op_Lt then
+ Kind := N_Op_Lt;
+ elsif Op_Name = Name_Op_Le then
+ Kind := N_Op_Le;
+ elsif Op_Name = Name_Op_Gt then
+ Kind := N_Op_Gt;
+ elsif Op_Name = Name_Op_Ge then
+ Kind := N_Op_Ge;
+ elsif Op_Name = Name_Op_Add then
+ Kind := N_Op_Add;
+ elsif Op_Name = Name_Op_Subtract then
+ Kind := N_Op_Subtract;
+ elsif Op_Name = Name_Op_Concat then
+ Kind := N_Op_Concat;
+ elsif Op_Name = Name_Op_Multiply then
+ Kind := N_Op_Multiply;
+ elsif Op_Name = Name_Op_Divide then
+ Kind := N_Op_Divide;
+ elsif Op_Name = Name_Op_Mod then
+ Kind := N_Op_Mod;
+ elsif Op_Name = Name_Op_Rem then
+ Kind := N_Op_Rem;
+ elsif Op_Name = Name_Op_Expon then
+ Kind := N_Op_Expon;
else
raise Program_Error;
end if;
-- Unary operators
else
- if Op_Name = Name_Op_Add then Kind := N_Op_Plus;
- elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus;
- elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs;
- elsif Op_Name = Name_Op_Not then Kind := N_Op_Not;
+ if Op_Name = Name_Op_Add then
+ Kind := N_Op_Plus;
+ elsif Op_Name = Name_Op_Subtract then
+ Kind := N_Op_Minus;
+ elsif Op_Name = Name_Op_Abs then
+ Kind := N_Op_Abs;
+ elsif Op_Name = Name_Op_Not then
+ Kind := N_Op_Not;
else
raise Program_Error;
end if;
Interp_Loop : while Present (It.Typ) loop
-- We are only interested in interpretations that are compatible
- -- with the expected type, any other interpretations are ignored
+ -- with the expected type, any other interpretations are ignored.
if not Covers (Typ, It.Typ) then
if Debug_Flag_V then
end if;
else
+ -- Skip the current interpretation if it is disabled by an
+ -- abstract operator. This action is performed only when the
+ -- type against which we are resolving is the same as the
+ -- type of the interpretation.
+
+ if Ada_Version >= Ada_05
+ and then It.Typ = Typ
+ and then Typ /= Universal_Integer
+ and then Typ /= Universal_Real
+ and then Present (It.Abstract_Op)
+ then
+ goto Continue;
+ end if;
+
-- First matching interpretation
if not Found then
end loop;
end;
- elsif Nkind (N) in N_Binary_Op
+ elsif Nkind (N) in N_Binary_Op
and then (Etype (Left_Opnd (N)) = Any_Type
or else Etype (Right_Opnd (N)) = Any_Type)
then
and then Scope (It.Nam) = Standard_Standard
and then Present (Err_Type)
then
- Error_Msg_N
- ("\\possible interpretation (predefined)#!", N);
+ -- Special-case the message for universal_fixed
+ -- operators, which are not declared with the type
+ -- of the operand, but appear forever in Standard.
+
+ if It.Typ = Universal_Fixed
+ and then Scope (It.Nam) = Standard_Standard
+ then
+ Error_Msg_N
+ ("\\possible interpretation as " &
+ "universal_fixed operation " &
+ "(RM 4.5.5 (19))", N);
+ else
+ Error_Msg_N
+ ("\\possible interpretation (predefined)#!", N);
+ end if;
elsif
Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
end if;
+ <<Continue>>
+
-- Move to next interpretation
exit Interp_Loop when No (It.Typ);
Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_Node_2 := It.Typ;
- Error_Msg_NE ("\& declared#, type&", N, It.Nam);
+ Error_Msg_Node_2 := It.Nam;
+ Error_Msg_NE
+ ("\\ type& for & declared#", N, It.Typ);
Get_Next_Interp (Index, It);
end loop;
end;
+
else
Error_Msg_N ("\use -gnatf for details", N);
end if;
if not Is_Aliased_View (Act) then
Error_Msg_NE
("object in prefixed call to& must be aliased"
- & " ('R'M'-2005 4.3.1 (13))",
+ & " (RM-2005 4.3.1 (13))",
Prefix (Act), Nam);
end if;
if Ada_Version >= Ada_05
and then Is_Access_Type (F_Typ)
and then Can_Never_Be_Null (F_Typ)
- and then Nkind (A) = N_Null
+ and then Known_Null (A)
then
Apply_Compile_Time_Constraint_Error
(N => A,
- Msg => "(Ada 2005) NULL not allowed in "
+ Msg => "(Ada 2005) null not allowed in "
& "null-excluding formal?",
Reason => CE_Null_Not_Allowed);
end if;
elsif Is_Access_Type (A_Typ)
and then Is_Access_Type (F_Typ)
and then Ekind (F_Typ) /= E_Access_Subprogram_Type
+ and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type
and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
or else (Nkind (A) = N_Attribute_Reference
and then
declare
Loc : constant Source_Ptr := Sloc (N);
begin
- Error_Msg_N ("?allocation from empty storage pool", N);
- Error_Msg_N ("\?Storage_Error will be raised at run time", N);
+ Error_Msg_N ("?allocation from empty storage pool!", N);
+ Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
if Nkind (N) = N_Allocator then
-- An anonymous access discriminant is the definition of a
- -- coextension
+ -- coextension.
if Ekind (Typ) = E_Anonymous_Access_Type
and then Nkind (Associated_Node_For_Itype (Typ)) =
N_Discriminant_Specification
then
-- Avoid marking an allocator as a dynamic coextension if it is
- -- withing a static construct.
+ -- within a static construct.
if not Is_Static_Coextension (N) then
- Set_Is_Coextension (N);
+ Set_Is_Dynamic_Coextension (N);
end if;
-- Cleanup for potential static coextensions
else
- Set_Is_Static_Coextension (N, False);
+ Set_Is_Dynamic_Coextension (N, False);
+ Set_Is_Static_Coextension (N, False);
end if;
- Propagate_Coextensions (N);
+ -- There is no need to propagate any nested coextensions if they
+ -- are marked as static since they will be rewritten on the spot.
+
+ if not Is_Static_Coextension (N) then
+ Propagate_Coextensions (N);
+ end if;
end if;
end Resolve_Allocator;
then
Rtype := Etype (N);
Error_Msg_NE
- ("& should not be used in entry body ('R'M C.7(17))?",
+ ("?& should not be used in entry body (RM C.7(17))",
N, Nam);
Error_Msg_NE
("\Program_Error will be raised at run time?", N, Nam);
Set_Has_Recursive_Call (Nam);
Error_Msg_N
- ("possible infinite recursion?", N);
+ ("?possible infinite recursion!", N);
Error_Msg_N
- ("\Storage_Error may be raised at run time?", N);
+ ("\?Storage_Error may be raised at run time!", N);
end if;
exit Scope_Loop;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
Acc := Designated_Type (Etype (R));
-
elsif Ekind (Etype (L)) = E_Allocator_Type then
Acc := Designated_Type (Etype (L));
-
else
return Empty;
end if;
and then Entity (R) = Standard_True
and then Comes_From_Source (R)
then
- Error_Msg_N ("comparison with True is redundant?", R);
+ Error_Msg_N ("?comparison with True is redundant!", R);
end if;
Check_Unset_Reference (L);
and then not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean
then
- Error_Msg_N ("?not expression should be parenthesized here", N);
+ Error_Msg_N ("?not expression should be parenthesized here!", N);
end if;
Resolve (Right_Opnd (N), B_Typ);
and then Warn_On_Bad_Fixed_Value
then
Error_Msg_N
- ("static fixed-point value is not a multiple of Small?",
+ ("?static fixed-point value is not a multiple of Small!",
N);
end if;
and then not Is_Constrained (Etype (Name)))
then
Array_Type := Get_Actual_Subtype (Name);
+
+ -- If the name is a selected component that depends on discriminants,
+ -- build an actual subtype for it. This can happen only when the name
+ -- itself is overloaded; otherwise the actual subtype is created when
+ -- the selected component is analyzed.
+
+ elsif Nkind (Name) = N_Selected_Component
+ and then Full_Analysis
+ and then Depends_On_Discriminant (First_Index (Array_Type))
+ then
+ declare
+ Act_Decl : constant Node_Id :=
+ Build_Actual_Subtype_Of_Component (Array_Type, Name);
+ begin
+ Insert_Action (N, Act_Decl);
+ Array_Type := Defining_Identifier (Act_Decl);
+ end;
end if;
-- If name was overloaded, set slice type correctly now
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
Error_Msg_N
- ("universal real operand can only " &
- "be interpreted as Duration?",
+ ("?universal real operand can only " &
+ "be interpreted as Duration!",
Rop);
Error_Msg_N
- ("\precision will be lost in the conversion", Rop);
+ ("\?precision will be lost in the conversion!", Rop);
end if;
elsif Is_Numeric_Type (Typ)
and then Etype (Entity (Orig_N)) = Orig_T
then
Error_Msg_NE
- ("?useless conversion, & has this type", N, Entity (Orig_N));
+ ("?useless conversion, & has this type!", N, Entity (Orig_N));
end if;
end if;
("type conversions require visibility of the full view",
N);
- elsif From_With_Type (Target) then
+ elsif From_With_Type (Target)
+ and then not
+ (Is_Access_Type (Target_Typ)
+ and then Present (Non_Limited_View (Etype (Target))))
+ then
Error_Msg_Qual_Level := 99;
Error_Msg_NE ("missing with-clause on package &", N,
Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
-- If we fall through warning should be issued
Error_Msg_N
- ("?unary minus expression should be parenthesized here", N);
+ ("?unary minus expression should be parenthesized here!", N);
end if;
end if;
end;
end loop;
if Nkind (N) = N_Real_Literal then
- Error_Msg_NE ("real literal interpreted as }?", N, T1);
+ Error_Msg_NE ("?real literal interpreted as }!", N, T1);
else
- Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
+ Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
end if;
return T1;
Operand);
Error_Msg_N
("\value has deeper accessibility than any master " &
- "('R'M 3.10.2 (13))",
+ "(RM 3.10.2 (13))",
Operand);
if Is_Entity_Name (Operand)
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;
- -- In an instance, there may be inconsistent views of the same
- -- type, or types derived from the same type.
+ -- In an instance or an inlined body, there may be inconsistent
+ -- views of the same type, or of types derived from a common root.
- elsif In_Instance
- and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
+ elsif (In_Instance or In_Inlined_Body)
+ and then
+ Root_Type (Underlying_Type (Target_Type)) =
+ Root_Type (Underlying_Type (Opnd_Type))
then
return True;
projects / gcc.git / commitdiff