Skip to content

R
riscv-gcc-1
Commit aa180613 by Robert Dewar Committed by Arnaud Charlet
Options

sem_res.adb (Resolve_Unary_Op): Add warning for use of unary minus with multiplying operator. 

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

        * sem_res.adb (Resolve_Unary_Op): Add warning for use of unary minus
	with multiplying operator.
	(Expected_Type_Is_Any_Real): New function to determine from the Parent
	pointer whether the context expects "any real type".
	(Resolve_Arithmetic_Op): Do not give an error on calls to the
	universal_fixed "*" and "/" operators when they are used in a context
	that expects any real type. Also set the type of the node to
	Universal_Real in this case, because downstream processing requires it
	(mainly static expression evaluation).
	Reword some continuation messages
	Add some \\ sequences to continuation messages
	(Resolve_Call): Refine infinite recursion case. The test has been
	sharpened to eliminate some false positives.
	Check for Current_Task usage now includes entry barrier, and is now a
	warning, not an error.
	(Resolve): If the call is ambiguous, indicate whether an interpretation
	is an inherited operation.
	(Check_Aggr): When resolving aggregates, skip associations with a box,
	which are priori correct, and will be replaced by an actual default
	expression in the course of expansion.
	(Resolve_Type_Conversion): Add missing support for conversion from
	a class-wide interface to a tagged type. Minor code cleanup.
	(Valid_Tagged_Converion): Add support for abstact interface type
	conversions.
	(Resolve_Selected_Component): Call Generate_Reference here rather than
	during analysis, and use May_Be_Lvalue to distinguish read/write.
	(Valid_Array_Conversion): New procedure, abstracted from
	Valid_Conversion, to incorporate accessibility checks for arrays of
	anonymous access types.
	(Valid_Conversion): For a conversion to a numeric type occurring in an
	instance or inlined body, no need to check that the operand type is
	numeric, since this has been checked during analysis of the template.
	Remove legacy test for scope name Unchecked_Conversion.

	* sem_res.ads: Minor reformatting

	* a-except.adb, a-except-2005.adb: Turn off subprogram ordering
	(PE_Current_Task_In_Entry_Body): New exception code
	(SE_Restriction_Violation): Removed, not used

	* a-except.ads:  Update comments.

	* types.h, types.ads: Add definition for Validity_Check
	(PE_Current_Task_In_Entry_Body): New exception code
	(SE_Restriction_Violation): Removed, not used

From-SVN: r118232
parent 524c02d7
Showing with 563 additions and 264 deletions
gcc/ada/a-except-2005.adb
...@@ -41,6 +41,9 @@ ...@@ -41,6 +41,9 @@
-- The base version of this unit Ada.Exceptions omits the Wide version of -- The base version of this unit Ada.Exceptions omits the Wide version of
-- Exception_Name and is used to build the compiler and other basic tools. -- Exception_Name and is used to build the compiler and other basic tools.
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
pragma Polling (Off); pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get -- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with System.Exception_Tables. -- elaboration circularities with System.Exception_Tables.
...@@ -555,23 +558,24 @@ package body Ada.Exceptions is ...@@ -555,23 +558,24 @@ package body Ada.Exceptions is
Rmsg_14 : constant String := "access before elaboration" & NUL; Rmsg_14 : constant String := "access before elaboration" & NUL;
Rmsg_15 : constant String := "accessibility check failed" & NUL; Rmsg_15 : constant String := "accessibility check failed" & NUL;
Rmsg_16 : constant String := "all guards closed" & NUL; Rmsg_16 : constant String := "all guards closed" & NUL;
Rmsg_17 : constant String := "duplicated entry address" & NUL; Rmsg_17 : constant String := "Current_Task referenced in entry" &
Rmsg_18 : constant String := "explicit raise" & NUL; " body" & NUL;
Rmsg_19 : constant String := "finalize/adjust raised exception" & NUL; Rmsg_18 : constant String := "duplicated entry address" & NUL;
Rmsg_20 : constant String := "implicit return with No_Return" & NUL; Rmsg_19 : constant String := "explicit raise" & NUL;
Rmsg_21 : constant String := "misaligned address value" & NUL; Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_22 : constant String := "missing return" & NUL; Rmsg_21 : constant String := "implicit return with No_Return" & NUL;
Rmsg_23 : constant String := "overlaid controlled object" & NUL; Rmsg_22 : constant String := "misaligned address value" & NUL;
Rmsg_24 : constant String := "potentially blocking operation" & NUL; Rmsg_23 : constant String := "missing return" & NUL;
Rmsg_25 : constant String := "stubbed subprogram called" & NUL; Rmsg_24 : constant String := "overlaid controlled object" & NUL;
Rmsg_26 : constant String := "unchecked union restriction" & NUL; Rmsg_25 : constant String := "potentially blocking operation" & NUL;
Rmsg_27 : constant String := "illegal use of remote access-to-" & Rmsg_26 : constant String := "stubbed subprogram called" & NUL;
Rmsg_27 : constant String := "unchecked union restriction" & NUL;
Rmsg_28 : constant String := "illegal use of remote access-to-" &
"class-wide type, see RM E.4(18)" & NUL; "class-wide type, see RM E.4(18)" & NUL;
Rmsg_28 : constant String := "empty storage pool" & NUL; Rmsg_29 : constant String := "empty storage pool" & NUL;
Rmsg_29 : constant String := "explicit raise" & NUL; Rmsg_30 : constant String := "explicit raise" & NUL;
Rmsg_30 : constant String := "infinite recursion" & NUL; Rmsg_31 : constant String := "infinite recursion" & NUL;
Rmsg_31 : constant String := "object too large" & NUL; Rmsg_32 : constant String := "object too large" & NUL;
Rmsg_32 : constant String := "restriction violation" & NUL;
----------------------- -----------------------
-- Polling Interface -- -- Polling Interface --
...@@ -1106,7 +1110,7 @@ package body Ada.Exceptions is ...@@ -1106,7 +1110,7 @@ package body Ada.Exceptions is
procedure Rcheck_28 (File : System.Address; Line : Integer) is procedure Rcheck_28 (File : System.Address; Line : Integer) is
begin begin
Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address); Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_28; end Rcheck_28;
procedure Rcheck_29 (File : System.Address; Line : Integer) is procedure Rcheck_29 (File : System.Address; Line : Integer) is
......
gcc/ada/a-except.adb
...@@ -31,8 +31,10 @@ ...@@ -31,8 +31,10 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This version of Ada.Exceptions is a full Ada 95 version, but lacks the -- This version of Ada.Exceptions is a full Ada 95 version, and Ada 2005
-- additional definitions of Exception_Name returning Wide_[Wide_]String. -- features such as the additional definitions of Exception_Name returning
-- Wide_[Wide_]String.
-- It is used for building the compiler and the basic tools, since these -- It is used for building the compiler and the basic tools, since these
-- builds may be done with bootstrap compilers that cannot handle these -- builds may be done with bootstrap compilers that cannot handle these
-- additions. The full version of Ada.Exceptions can be found in the files -- additions. The full version of Ada.Exceptions can be found in the files
...@@ -40,6 +42,9 @@ ...@@ -40,6 +42,9 @@
-- 2005 functionality is required. in particular, it is used for building -- 2005 functionality is required. in particular, it is used for building
-- run times on all targets. -- run times on all targets.
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
pragma Polling (Off); pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get -- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with System.Exception_Tables. -- elaboration circularities with System.Exception_Tables.
...@@ -206,7 +211,7 @@ package body Ada.Exceptions is ...@@ -206,7 +211,7 @@ package body Ada.Exceptions is
(Excep : EOA; (Excep : EOA;
Current : EOA; Current : EOA;
Reraised : Boolean := False); Reraised : Boolean := False);
-- Dummy routine used to share a-exexda.adb, do nothing. -- Dummy routine used to share a-exexda.adb, do nothing
end Exception_Propagation; end Exception_Propagation;
...@@ -504,23 +509,24 @@ package body Ada.Exceptions is ...@@ -504,23 +509,24 @@ package body Ada.Exceptions is
Rmsg_14 : constant String := "access before elaboration" & NUL; Rmsg_14 : constant String := "access before elaboration" & NUL;
Rmsg_15 : constant String := "accessibility check failed" & NUL; Rmsg_15 : constant String := "accessibility check failed" & NUL;
Rmsg_16 : constant String := "all guards closed" & NUL; Rmsg_16 : constant String := "all guards closed" & NUL;
Rmsg_17 : constant String := "duplicated entry address" & NUL; Rmsg_17 : constant String := "Current_Task referenced in entry" &
Rmsg_18 : constant String := "explicit raise" & NUL; " body" & NUL;
Rmsg_19 : constant String := "finalize/adjust raised exception" & NUL; Rmsg_18 : constant String := "duplicated entry address" & NUL;
Rmsg_20 : constant String := "implicit return with No_Return" & NUL; Rmsg_19 : constant String := "explicit raise" & NUL;
Rmsg_21 : constant String := "misaligned address value" & NUL; Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_22 : constant String := "missing return" & NUL; Rmsg_21 : constant String := "implicit return with No_Return" & NUL;
Rmsg_23 : constant String := "overlaid controlled object" & NUL; Rmsg_22 : constant String := "misaligned address value" & NUL;
Rmsg_24 : constant String := "potentially blocking operation" & NUL; Rmsg_23 : constant String := "missing return" & NUL;
Rmsg_25 : constant String := "stubbed subprogram called" & NUL; Rmsg_24 : constant String := "overlaid controlled object" & NUL;
Rmsg_26 : constant String := "unchecked union restriction" & NUL; Rmsg_25 : constant String := "potentially blocking operation" & NUL;
Rmsg_27 : constant String := "illegal use of remote access-to-" & Rmsg_26 : constant String := "stubbed subprogram called" & NUL;
Rmsg_27 : constant String := "unchecked union restriction" & NUL;
Rmsg_28 : constant String := "illegal use of remote access-to-" &
"class-wide type, see RM E.4(18)" & NUL; "class-wide type, see RM E.4(18)" & NUL;
Rmsg_28 : constant String := "empty storage pool" & NUL; Rmsg_29 : constant String := "empty storage pool" & NUL;
Rmsg_29 : constant String := "explicit raise" & NUL; Rmsg_30 : constant String := "explicit raise" & NUL;
Rmsg_30 : constant String := "infinite recursion" & NUL; Rmsg_31 : constant String := "infinite recursion" & NUL;
Rmsg_31 : constant String := "object too large" & NUL; Rmsg_32 : constant String := "object too large" & NUL;
Rmsg_32 : constant String := "restriction violation" & NUL;
----------------------- -----------------------
-- Polling Interface -- -- Polling Interface --
...@@ -802,11 +808,7 @@ package body Ada.Exceptions is ...@@ -802,11 +808,7 @@ package body Ada.Exceptions is
Raise_Current_Excep (E); Raise_Current_Excep (E);
end if; end if;
-- Note: if E is null, then we simply return, which is correct Ada 95 -- Note: if E is null then just return (Ada 95 semantics)
-- semantics. If we are operating in Ada 2005 mode, then the expander
-- generates a raise Constraint_Error immediately following the call
-- to provide the required Ada 2005 semantics (see AI-329). We do it
-- this way to avoid having run time dependencies on the Ada version.
return; return;
end Raise_Exception; end Raise_Exception;
...@@ -1072,7 +1074,7 @@ package body Ada.Exceptions is ...@@ -1072,7 +1074,7 @@ package body Ada.Exceptions is
procedure Rcheck_28 (File : System.Address; Line : Integer) is procedure Rcheck_28 (File : System.Address; Line : Integer) is
begin begin
Raise_Storage_Error_Msg (File, Line, Rmsg_28'Address); Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_28; end Rcheck_28;
procedure Rcheck_29 (File : System.Address; Line : Integer) is procedure Rcheck_29 (File : System.Address; Line : Integer) is
......
gcc/ada/a-except.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -35,8 +35,7 @@ ...@@ -35,8 +35,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This version of Ada.Exceptions is a full Ada 95 version, but lacks the -- This version of Ada.Exceptions is a full Ada 95 version.
-- additional definitions of Exception_Name returning Wide_[Wide_]String.
-- It is used for building the compiler and the basic tools, since these -- It is used for building the compiler and the basic tools, since these
-- builds may be done with bootstrap compilers that cannot handle these -- builds may be done with bootstrap compilers that cannot handle these
-- additions. The full version of Ada.Exceptions can be found in the files -- additions. The full version of Ada.Exceptions can be found in the files
...@@ -57,14 +56,17 @@ package Ada.Exceptions is ...@@ -57,14 +56,17 @@ package Ada.Exceptions is
pragma Warnings (Off); pragma Warnings (Off);
pragma Preelaborate_05; pragma Preelaborate_05;
pragma Warnings (On); pragma Warnings (On);
-- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we -- We make this preelaborable in Ada 2005 mode. If we did not do this, then
-- can compile this using older compiler versions, which will ignore the -- run time units used by the compiler (e.g. s-soflin.ads) would run
-- pragma, which is fine for the bootstrap. -- into trouble. Conformance is not an issue, since this version is used
-- only by the compiler.
type Exception_Id is private; type Exception_Id is private;
Null_Id : constant Exception_Id; Null_Id : constant Exception_Id;
type Exception_Occurrence is limited private; type Exception_Occurrence is limited private;
type Exception_Occurrence_Access is access all Exception_Occurrence; type Exception_Occurrence_Access is access all Exception_Occurrence;
Null_Occurrence : constant Exception_Occurrence; Null_Occurrence : constant Exception_Occurrence;
...@@ -76,11 +78,11 @@ package Ada.Exceptions is ...@@ -76,11 +78,11 @@ package Ada.Exceptions is
procedure Raise_Exception (E : Exception_Id; Message : String := ""); procedure Raise_Exception (E : Exception_Id; Message : String := "");
-- Note: it would be really nice to give a pragma No_Return for this -- Note: it would be really nice to give a pragma No_Return for this
-- procedure, but it would be wrong, since Raise_Exception does return -- procedure, but it would be wrong, since Raise_Exception does return if
-- if given the null exception. However we do special case the name in -- given the null exception in Ada 95 mode. However we do special case the
-- the test in the compiler for issuing a warning for a missing return -- name in the test in the compiler for issuing a warning for a missing
-- after this call. Program_Error seems reasonable enough in such a case. -- return after this call. Program_Error seems reasonable enough in such a
-- See also the routine Raise_Exception_Always in the private part. -- case. See also the routine Raise_Exception_Always in the private part.
function Exception_Message (X : Exception_Occurrence) return String; function Exception_Message (X : Exception_Occurrence) return String;
......
gcc/ada/sem_res.adb
...@@ -241,11 +241,11 @@ package body Sem_Res is ...@@ -241,11 +241,11 @@ package body Sem_Res is
if Nkind (C) = N_Character_Literal then if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C); Error_Msg_N ("ambiguous character literal", C);
Error_Msg_N Error_Msg_N
("\possible interpretations: Character, Wide_Character!", C); ("\\possible interpretations: Character, Wide_Character!", C);
E := Current_Entity (C); E := Current_Entity (C);
while Present (E) loop while Present (E) loop
Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
E := Homonym (E); E := Homonym (E);
end loop; end loop;
end if; end if;
...@@ -1823,12 +1823,20 @@ package body Sem_Res is ...@@ -1823,12 +1823,20 @@ package body Sem_Res is
-- message only at the start of an ambiguous set. -- message only at the start of an ambiguous set.
if not Ambiguous then if not Ambiguous then
Error_Msg_NE if Nkind (N) = N_Function_Call
("ambiguous expression (cannot resolve&)!", and then Nkind (Name (N)) = N_Explicit_Dereference
N, It.Nam); then
Error_Msg_N
("ambiguous expression "
& "(cannot resolve indirect call)!", N);
else
Error_Msg_NE
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
end if;
Error_Msg_N Error_Msg_N
("possible interpretation#!", N); ("\\possible interpretation#!", N);
Ambiguous := True; Ambiguous := True;
end if; end if;
...@@ -1857,7 +1865,7 @@ package body Sem_Res is ...@@ -1857,7 +1865,7 @@ package body Sem_Res is
elsif Nkind (N) in N_Binary_Op elsif Nkind (N) in N_Binary_Op
and then Scope (It.Nam) = Standard_Standard and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Left_Opnd (N)) and then not Is_Overloaded (Left_Opnd (N))
and then Scope (Base_Type (Etype (Left_Opnd (N)))) and then Scope (Base_Type (Etype (Left_Opnd (N))))
/= Standard_Standard /= Standard_Standard
then then
Err_Type := First_Subtype (Etype (Left_Opnd (N))); Err_Type := First_Subtype (Etype (Left_Opnd (N)));
...@@ -1867,6 +1875,20 @@ package body Sem_Res is ...@@ -1867,6 +1875,20 @@ package body Sem_Res is
then then
Error_Msg_Sloc := Sloc (Parent (Err_Type)); Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if; end if;
-- If this is an indirect call, use the subprogram_type
-- in the message, to have a meaningful location.
-- Indicate as well if this is an inherited operation,
-- created by a type declaration.
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Type (It.Nam)
then
Err_Type := It.Nam;
Error_Msg_Sloc :=
Sloc (Associated_Node_For_Itype (Err_Type));
else else
Err_Type := Empty; Err_Type := Empty;
end if; end if;
...@@ -1876,9 +1898,15 @@ package body Sem_Res is ...@@ -1876,9 +1898,15 @@ package body Sem_Res is
and then Present (Err_Type) and then Present (Err_Type)
then then
Error_Msg_N Error_Msg_N
("possible interpretation (predefined)#!", N); ("\\possible interpretation (predefined)#!", N);
elsif
Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
then
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else else
Error_Msg_N ("possible interpretation#!", N); Error_Msg_N ("\\possible interpretation#!", N);
end if; end if;
end if; end if;
...@@ -2012,16 +2040,14 @@ package body Sem_Res is ...@@ -2012,16 +2040,14 @@ package body Sem_Res is
Set_Etype (N, Typ); Set_Etype (N, Typ);
return; return;
-- Check for an aggregate. Sometimes we can get bogus -- Check for an aggregate. Sometimes we can get bogus aggregates
-- aggregates from misuse of parentheses, and we are -- from misuse of parentheses, and we are about to complain about
-- about to complain about the aggregate without even -- the aggregate without even looking inside it.
-- looking inside it.
-- Instead, if we have an aggregate of type Any_Composite, -- Instead, if we have an aggregate of type Any_Composite, then
-- then analyze and resolve the component fields, and then -- analyze and resolve the component fields, and then only issue
-- only issue another message if we get no errors doing -- another message if we get no errors doing this (otherwise
-- this (otherwise assume that the errors in the aggregate -- assume that the errors in the aggregate caused the problem).
-- caused the problem).
elsif Nkind (N) = N_Aggregate elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite and then Etype (N) = Any_Composite
...@@ -2034,12 +2060,16 @@ package body Sem_Res is ...@@ -2034,12 +2060,16 @@ package body Sem_Res is
declare declare
procedure Check_Aggr (Aggr : Node_Id); procedure Check_Aggr (Aggr : Node_Id);
-- Check one aggregate, and set Found to True if we -- Check one aggregate, and set Found to True if we have a
-- have a definite error in any of its elements -- definite error in any of its elements
procedure Check_Elmt (Aelmt : Node_Id); procedure Check_Elmt (Aelmt : Node_Id);
-- Check one element of aggregate and set Found to -- Check one element of aggregate and set Found to True if
-- True if we definitely have an error in the element. -- we definitely have an error in the element.
----------------
-- Check_Aggr --
----------------
procedure Check_Aggr (Aggr : Node_Id) is procedure Check_Aggr (Aggr : Node_Id) is
Elmt : Node_Id; Elmt : Node_Id;
...@@ -2056,7 +2086,16 @@ package body Sem_Res is ...@@ -2056,7 +2086,16 @@ package body Sem_Res is
if Present (Component_Associations (Aggr)) then if Present (Component_Associations (Aggr)) then
Elmt := First (Component_Associations (Aggr)); Elmt := First (Component_Associations (Aggr));
while Present (Elmt) loop while Present (Elmt) loop
Check_Elmt (Expression (Elmt));
-- Nothing to check is this is a default-
-- initialized component. The box will be
-- be replaced by the appropriate call during
-- late expansion.
if not Box_Present (Elmt) then
Check_Elmt (Expression (Elmt));
end if;
Next (Elmt); Next (Elmt);
end loop; end loop;
end if; end if;
...@@ -2131,7 +2170,7 @@ package body Sem_Res is ...@@ -2131,7 +2170,7 @@ package body Sem_Res is
It : Interp; It : Interp;
begin begin
Error_Msg_N ("\possible interpretations:", N); Error_Msg_N ("\\possible interpretations:", N);
Get_First_Interp (Name (N), Index, It); Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop while Present (It.Nam) loop
...@@ -2254,7 +2293,7 @@ package body Sem_Res is ...@@ -2254,7 +2293,7 @@ package body Sem_Res is
when N_Identifier when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type); => Resolve_Entity_Name (N, Ctx_Type);
when N_In | N_Not_In when N_Membership_Test
=> Resolve_Membership_Op (N, Ctx_Type); => Resolve_Membership_Op (N, Ctx_Type);
when N_Indexed_Component when N_Indexed_Component
...@@ -3167,7 +3206,12 @@ package body Sem_Res is ...@@ -3167,7 +3206,12 @@ package body Sem_Res is
Make_Raise_Program_Error (Sloc (N), Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Typ); Set_Etype (N, Typ);
else
-- Do not apply Ada 2005 accessibility checks on a class-wide
-- allocator if the type given in the allocator is a formal
-- type. A run-time check will be performed in the instance.
elsif not Is_Generic_Type (Exp_Typ) then
Error_Msg_N ("type in allocator has deeper level than" & Error_Msg_N ("type in allocator has deeper level than" &
" designated class-wide type", E); " designated class-wide type", E);
end if; end if;
...@@ -3219,6 +3263,9 @@ package body Sem_Res is ...@@ -3219,6 +3263,9 @@ package body Sem_Res is
-- We do the resolution using the base type, because intermediate values -- We do the resolution using the base type, because intermediate values
-- in expressions always are of the base type, not a subtype of it. -- in expressions always are of the base type, not a subtype of it.
function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean;
-- Returns True if N is in a context that expects "any real type"
function Is_Integer_Or_Universal (N : Node_Id) return Boolean; function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
-- Return True iff given type is Integer or universal real/integer -- Return True iff given type is Integer or universal real/integer
...@@ -3230,6 +3277,29 @@ package body Sem_Res is ...@@ -3230,6 +3277,29 @@ package body Sem_Res is
procedure Set_Operand_Type (N : Node_Id); procedure Set_Operand_Type (N : Node_Id);
-- Set operand type to T if universal -- Set operand type to T if universal
-------------------------------
-- Expected_Type_Is_Any_Real --
-------------------------------
function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is
begin
-- 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
-- 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 is the expression of a delta_constraint;
-- see RM-J.3(3):
or else Nkind (Parent (N)) = N_Delta_Constraint;
end Expected_Type_Is_Any_Real;
----------------------------- -----------------------------
-- Is_Integer_Or_Universal -- -- Is_Integer_Or_Universal --
----------------------------- -----------------------------
...@@ -3467,10 +3537,17 @@ package body Sem_Res is ...@@ -3467,10 +3537,17 @@ package body Sem_Res is
Set_Mixed_Mode_Operand (R, TL); Set_Mixed_Mode_Operand (R, TL);
end if; 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.
if Etype (N) = Universal_Fixed if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed or else Etype (N) = Any_Fixed
then then
if B_Typ = Universal_Fixed 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_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
then then
...@@ -3494,7 +3571,16 @@ package body Sem_Res is ...@@ -3494,7 +3571,16 @@ package body Sem_Res is
N); N);
end if; end if;
Set_Etype (N, B_Typ); -- The expected type is "any real type" in contexts like
-- type T is delta <universal_fixed-expression> ...
-- in which case we need to set the type to Universal_Real
-- so that static expression evaluation will work properly.
if Expected_Type_Is_Any_Real (N) then
Set_Etype (N, Universal_Real);
else
Set_Etype (N, B_Typ);
end if;
end if; end if;
elsif Is_Fixed_Point_Type (B_Typ) elsif Is_Fixed_Point_Type (B_Typ)
...@@ -3582,9 +3668,30 @@ package body Sem_Res is ...@@ -3582,9 +3668,30 @@ package body Sem_Res is
(Is_Real_Type (Etype (Rop)) (Is_Real_Type (Etype (Rop))
and then Expr_Value_R (Rop) = Ureal_0)) and then Expr_Value_R (Rop) = Ureal_0))
then then
Apply_Compile_Time_Constraint_Error -- Specialize the warning message according to the operation
(N, "division by zero?", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N))); case Nkind (N) is
when N_Op_Divide =>
Apply_Compile_Time_Constraint_Error
(N, "division by zero?", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
when N_Op_Rem =>
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor?", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
when N_Op_Mod =>
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor?", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
-- Division by zero can only happen with division, rem,
-- and mod operations.
when others =>
raise Program_Error;
end case;
-- Otherwise just set the flag to check at run time -- Otherwise just set the flag to check at run time
...@@ -3610,6 +3717,7 @@ package body Sem_Res is ...@@ -3610,6 +3717,7 @@ package body Sem_Res is
It : Interp; It : Interp;
Norm_OK : Boolean; Norm_OK : Boolean;
Scop : Entity_Id; Scop : Entity_Id;
Rtype : Entity_Id;
begin begin
-- The context imposes a unique interpretation with type Typ on a -- The context imposes a unique interpretation with type Typ on a
...@@ -3656,7 +3764,7 @@ package body Sem_Res is ...@@ -3656,7 +3764,7 @@ package body Sem_Res is
-- For an indirect call, we always invalidate checks, since we do not -- For an indirect call, we always invalidate checks, since we do not
-- know whether the subprogram is local or global. Yes we could do -- know whether the subprogram is local or global. Yes we could do
-- better here, e.g. by knowing that there are no local subprograms, -- better here, e.g. by knowing that there are no local subprograms,
-- but it does not seem worth the effort. Similarly, we kill al -- but it does not seem worth the effort. Similarly, we kill all
-- knowledge of current constant values. -- knowledge of current constant values.
Kill_Current_Values; Kill_Current_Values;
...@@ -3718,10 +3826,20 @@ package body Sem_Res is ...@@ -3718,10 +3826,20 @@ package body Sem_Res is
P := Parent (P); P := Parent (P);
exit when No (P); exit when No (P);
if Nkind (P) = N_Entry_Body then if Nkind (P) = N_Entry_Body
or else (Nkind (P) = N_Subprogram_Body
and then Is_Entry_Barrier_Function (P))
then
Rtype := Etype (N);
Error_Msg_NE Error_Msg_NE
("& should not be used in entry body ('R'M C.7(17))", ("& should not be used in entry body ('R'M C.7(17))?",
N, Nam); N, Nam);
Error_Msg_NE
("\Program_Error will be raised at run time?", N, Nam);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Current_Task_In_Entry_Body));
Set_Etype (N, Rtype);
exit; exit;
end if; end if;
end loop; end loop;
...@@ -3734,25 +3852,6 @@ package body Sem_Res is ...@@ -3734,25 +3852,6 @@ package body Sem_Res is
Error_Msg_N ("cannot call thread body directly", N); Error_Msg_N ("cannot call thread body directly", N);
end if; end if;
-- If the subprogram is not global, then kill all checks. This is a bit
-- conservative, since in many cases we could do better, but it is not
-- worth the effort. Similarly, we kill constant values. However we do
-- not need to do this for internal entities (unless they are inherited
-- user-defined subprograms), since they are not in the business of
-- molesting global values.
if not Is_Library_Level_Entity (Nam)
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
then
Kill_Current_Values;
end if;
-- Check for call to subprogram marked Is_Obsolescent
Check_Obsolescent (Nam, N);
-- Check that a procedure call does not occur in the context of the -- Check that a procedure call does not occur in the context of the
-- entry call statement of a conditional or timed entry call. Note that -- entry call statement of a conditional or timed entry call. Note that
-- the case of a call to a subprogram renaming of an entry will also be -- the case of a call to a subprogram renaming of an entry will also be
...@@ -3914,15 +4013,16 @@ package body Sem_Res is ...@@ -3914,15 +4013,16 @@ package body Sem_Res is
-- the case of a possible run-time detectable infinite recursion. -- the case of a possible run-time detectable infinite recursion.
else else
while Scop /= Standard_Standard loop Scope_Loop : while Scop /= Standard_Standard loop
if Nam = Scop then if Nam = Scop then
-- Although in general recursion is not statically checkable, -- Although in general recursion is not statically checkable,
-- the case of calling an immediately containing subprogram -- the case of calling an immediately containing subprogram
-- is easy to catch. -- is easy to catch.
Check_Restriction (No_Recursion, N); Check_Restriction (No_Recursion, N);
-- If the recursive call is to a parameterless procedure, then -- If the recursive call is to a parameterless subprogram, then
-- even if we can't statically detect infinite recursion, this -- even if we can't statically detect infinite recursion, this
-- is pretty suspicious, and we output a warning. Furthermore, -- is pretty suspicious, and we output a warning. Furthermore,
-- we will try later to detect some cases here at run time by -- we will try later to detect some cases here at run time by
...@@ -3938,16 +4038,58 @@ package body Sem_Res is ...@@ -3938,16 +4038,58 @@ package body Sem_Res is
and then not Error_Posted (N) and then not Error_Posted (N)
and then Nkind (Parent (N)) /= N_Exception_Handler and then Nkind (Parent (N)) /= N_Exception_Handler
then then
-- For the case of a procedure call. We give the message
-- only if the call is the first statement in a sequence of
-- statements, or if all previous statements are simple
-- assignments. This is simply a heuristic to decrease false
-- positives, without losing too many good warnings. The
-- idea is that these previous statements may affect global
-- variables the procedure depends on.
if Nkind (N) = N_Procedure_Call_Statement
and then Is_List_Member (N)
then
declare
P : Node_Id;
begin
P := Prev (N);
while Present (P) loop
if Nkind (P) /= N_Assignment_Statement then
exit Scope_Loop;
end if;
Prev (P);
end loop;
end;
end if;
-- Do not give warning if we are in a conditional context
declare
K : constant Node_Kind := Nkind (Parent (N));
begin
if (K = N_Loop_Statement
and then Present (Iteration_Scheme (Parent (N))))
or else K = N_If_Statement
or else K = N_Elsif_Part
or else K = N_Case_Statement_Alternative
then
exit Scope_Loop;
end if;
end;
-- Here warning is to be issued
Set_Has_Recursive_Call (Nam); Set_Has_Recursive_Call (Nam);
Error_Msg_N ("possible infinite recursion?", N); Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N); Error_Msg_N ("\Storage_Error may be raised at run time?", N);
end if; end if;
exit; exit Scope_Loop;
end if; end if;
Scop := Scope (Scop); Scop := Scope (Scop);
end loop; end loop Scope_Loop;
end if; end if;
-- If subprogram name is a predefined operator, it was given in -- If subprogram name is a predefined operator, it was given in
...@@ -4044,6 +4186,25 @@ package body Sem_Res is ...@@ -4044,6 +4186,25 @@ package body Sem_Res is
return; return;
end if; end if;
-- If the subprogram is not global, then kill all checks. This is a bit
-- conservative, since in many cases we could do better, but it is not
-- worth the effort. Similarly, we kill constant values. However we do
-- not need to do this for internal entities (unless they are inherited
-- user-defined subprograms), since they are not in the business of
-- molesting global values.
-- Note: we do not do this step till after resolving the actuals. That
-- way we still take advantage of the current value information while
-- scanning the actuals.
if not Is_Library_Level_Entity (Nam)
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
then
Kill_Current_Values;
end if;
-- If the subprogram is a primitive operation, check whether or not -- If the subprogram is a primitive operation, check whether or not
-- it is a correct dispatching call. -- it is a correct dispatching call.
...@@ -5180,6 +5341,7 @@ package body Sem_Res is ...@@ -5180,6 +5341,7 @@ package body Sem_Res is
end loop; end loop;
end if; end if;
Warn_On_Suspicious_Index (Name, First (Expressions (N)));
Eval_Indexed_Component (N); Eval_Indexed_Component (N);
end Resolve_Indexed_Component; end Resolve_Indexed_Component;
...@@ -5557,14 +5719,14 @@ package body Sem_Res is ...@@ -5557,14 +5719,14 @@ package body Sem_Res is
Error_Msg_Sloc := Sloc (Func); Error_Msg_Sloc := Sloc (Func);
Error_Msg_N ("\ambiguous call to function#", Arg); Error_Msg_N ("\ambiguous call to function#", Arg);
Error_Msg_NE Error_Msg_NE
("\interpretation as call yields&", Arg, Typ); ("\\interpretation as call yields&", Arg, Typ);
Error_Msg_NE Error_Msg_NE
("\interpretation as indexing of call yields&", ("\\interpretation as indexing of call yields&",
Arg, Component_Type (Typ)); Arg, Component_Type (Typ));
else else
Error_Msg_N ("ambiguous operand for concatenation!", Error_Msg_N
Arg); ("ambiguous operand for concatenation!", Arg);
Get_First_Interp (Arg, I, It); Get_First_Interp (Arg, I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam); Error_Msg_Sloc := Sloc (It.Nam);
...@@ -5573,7 +5735,7 @@ package body Sem_Res is ...@@ -5573,7 +5735,7 @@ package body Sem_Res is
or else Base_Type (It.Typ) = or else Base_Type (It.Typ) =
Base_Type (Component_Type (Typ)) Base_Type (Component_Type (Typ))
then then
Error_Msg_N ("\possible interpretation#", Arg); Error_Msg_N ("\\possible interpretation#", Arg);
end if; end if;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
...@@ -5723,6 +5885,10 @@ package body Sem_Res is ...@@ -5723,6 +5885,10 @@ package body Sem_Res is
-- and the not in question is the left operand of this operation. -- and the not in question is the left operand of this operation.
-- Note that if the not is in parens, then false is returned. -- Note that if the not is in parens, then false is returned.
-----------------------
-- Parent_Is_Boolean --
-----------------------
function Parent_Is_Boolean return Boolean is function Parent_Is_Boolean return Boolean is
begin begin
if Paren_Count (N) /= 0 then if Paren_Count (N) /= 0 then
...@@ -5742,7 +5908,7 @@ package body Sem_Res is ...@@ -5742,7 +5908,7 @@ package body Sem_Res is
N_In | N_In |
N_Not_In | N_Not_In |
N_And_Then | N_And_Then |
N_Or_Else => N_Or_Else =>
return Left_Opnd (Parent (N)) = N; return Left_Opnd (Parent (N)) = N;
...@@ -5765,11 +5931,15 @@ package body Sem_Res is ...@@ -5765,11 +5931,15 @@ package body Sem_Res is
B_Typ := Base_Type (Typ); B_Typ := Base_Type (Typ);
end if; end if;
-- Straigtforward case of incorrect arguments
if not Valid_Boolean_Arg (Typ) then if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N); Error_Msg_N ("invalid operand type for operator&", N);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
return; return;
-- Special case of probable missing parens
elsif Typ = Universal_Integer or else Typ = Any_Modular then elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then if Parent_Is_Boolean then
Error_Msg_N Error_Msg_N
...@@ -5783,8 +5953,15 @@ package body Sem_Res is ...@@ -5783,8 +5953,15 @@ package body Sem_Res is
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
return; return;
-- OK resolution of not
else else
if not Is_Boolean_Type (Typ) -- Warn if non-boolean types involved. This is a case like not a < b
-- where a and b are modular, where we will get (not a) < b and most
-- likely not (a < b) was intended.
if Warn_On_Questionable_Missing_Parens
and then not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean and then Parent_Is_Boolean
then then
Error_Msg_N ("?not expression should be parenthesized here", N); Error_Msg_N ("?not expression should be parenthesized here", N);
...@@ -6111,7 +6288,7 @@ package body Sem_Res is ...@@ -6111,7 +6288,7 @@ package body Sem_Res is
Resolve (P, It1.Typ); Resolve (P, It1.Typ);
Set_Etype (N, Typ); Set_Etype (N, Typ);
Set_Entity (S, Comp1); Set_Entity_With_Style_Check (S, Comp1);
else else
-- Resolve prefix with its type -- Resolve prefix with its type
...@@ -6119,6 +6296,16 @@ package body Sem_Res is ...@@ -6119,6 +6296,16 @@ package body Sem_Res is
Resolve (P, T); Resolve (P, T);
end if; end if;
-- Generate cross-reference. We needed to wait until full overloading
-- resolution was complete to do this, since otherwise we can't tell if
-- we are an Lvalue of not.
if May_Be_Lvalue (N) then
Generate_Reference (Entity (S), S, 'm');
else
Generate_Reference (Entity (S), S, 'r');
end if;
-- If prefix is an access type, the node will be transformed into an -- If prefix is an access type, the node will be transformed into an
-- explicit dereference during expansion. The type of the node is the -- explicit dereference during expansion. The type of the node is the
-- designated type of that of the prefix. -- designated type of that of the prefix.
...@@ -6317,6 +6504,12 @@ package body Sem_Res is ...@@ -6317,6 +6504,12 @@ package body Sem_Res is
end if; end if;
Set_Slice_Subtype (N); Set_Slice_Subtype (N);
if Nkind (Drange) = N_Range then
Warn_On_Suspicious_Index (Name, Low_Bound (Drange));
Warn_On_Suspicious_Index (Name, High_Bound (Drange));
end if;
Eval_Slice (N); Eval_Slice (N);
end Resolve_Slice; end Resolve_Slice;
...@@ -6654,9 +6847,12 @@ package body Sem_Res is ...@@ -6654,9 +6847,12 @@ package body Sem_Res is
and then Realval (Rop) /= Ureal_0 and then Realval (Rop) /= Ureal_0
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then then
Error_Msg_N ("universal real operand can only be interpreted?", Error_Msg_N
Rop); ("universal real operand can only " &
Error_Msg_N ("\as Duration, and will lose precision?", Rop); "be interpreted as Duration?",
Rop);
Error_Msg_N
("\precision will be lost in the conversion", Rop);
end if; end if;
elsif Is_Numeric_Type (Typ) elsif Is_Numeric_Type (Typ)
...@@ -6734,7 +6930,7 @@ package body Sem_Res is ...@@ -6734,7 +6930,7 @@ package body Sem_Res is
-- Ada 2005 (AI-251): Handle conversions to abstract interface types -- Ada 2005 (AI-251): Handle conversions to abstract interface types
if Ada_Version >= Ada_05 then if Ada_Version >= Ada_05 and then Expander_Active then
if Is_Access_Type (Target_Type) then if Is_Access_Type (Target_Type) then
Target_Type := Directly_Designated_Type (Target_Type); Target_Type := Directly_Designated_Type (Target_Type);
end if; end if;
...@@ -6770,9 +6966,18 @@ package body Sem_Res is ...@@ -6770,9 +6966,18 @@ package body Sem_Res is
-- conversion at run-time. -- conversion at run-time.
Expand_Interface_Conversion (N, Is_Static => False); Expand_Interface_Conversion (N, Is_Static => False);
else else
Expand_Interface_Conversion (N); Expand_Interface_Conversion (N);
end if; end if;
-- Ada 2005 (AI-251): Conversion from a class-wide interface to a
-- tagged type
elsif Is_Class_Wide_Type (Opnd_Type)
and then Is_Interface (Opnd_Type)
then
Expand_Interface_Conversion (N, Is_Static => False);
end if; end if;
end if; end if;
end Resolve_Type_Conversion; end Resolve_Type_Conversion;
...@@ -6791,10 +6996,11 @@ package body Sem_Res is ...@@ -6791,10 +6996,11 @@ package body Sem_Res is
begin begin
-- Generate warning for expressions like -5 mod 3 -- Generate warning for expressions like -5 mod 3
if Paren_Count (N) = 0 if Warn_On_Questionable_Missing_Parens
and then Nkind (N) = N_Op_Minus 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 Paren_Count (Right_Opnd (N)) = 0
and then Nkind (Right_Opnd (N)) = N_Op_Mod and then Nkind (Right_Opnd (N)) in N_Multiplying_Operator
and then Comes_From_Source (N) and then Comes_From_Source (N)
then then
Error_Msg_N Error_Msg_N
...@@ -7161,8 +7367,8 @@ package body Sem_Res is ...@@ -7161,8 +7367,8 @@ package body Sem_Res is
procedure Fixed_Point_Error is procedure Fixed_Point_Error is
begin begin
Error_Msg_N ("ambiguous universal_fixed_expression", N); Error_Msg_N ("ambiguous universal_fixed_expression", N);
Error_Msg_NE ("\possible interpretation as}", N, T1); Error_Msg_NE ("\\possible interpretation as}", N, T1);
Error_Msg_NE ("\possible interpretation as}", N, T2); Error_Msg_NE ("\\possible interpretation as}", N, T2);
end Fixed_Point_Error; end Fixed_Point_Error;
-- Start of processing for Unique_Fixed_Point_Type -- Start of processing for Unique_Fixed_Point_Type
...@@ -7257,6 +7463,10 @@ package body Sem_Res is ...@@ -7257,6 +7463,10 @@ package body Sem_Res is
Opnd_Type : Entity_Id) return Boolean; Opnd_Type : Entity_Id) return Boolean;
-- Specifically test for validity of tagged conversions -- Specifically test for validity of tagged conversions
function Valid_Array_Conversion return Boolean;
-- Check index and component conformance, and accessibility levels
-- if the component types are anonymous access types (Ada 2005)
---------------------- ----------------------
-- Conversion_Check -- -- Conversion_Check --
---------------------- ----------------------
...@@ -7273,6 +7483,135 @@ package body Sem_Res is ...@@ -7273,6 +7483,135 @@ package body Sem_Res is
return Valid; return Valid;
end Conversion_Check; end Conversion_Check;
----------------------------
-- Valid_Array_Conversion --
----------------------------
function Valid_Array_Conversion return Boolean
is
Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
Opnd_Index : Node_Id;
Opnd_Index_Type : Entity_Id;
Target_Comp_Type : constant Entity_Id :=
Component_Type (Target_Type);
Target_Comp_Base : constant Entity_Id :=
Base_Type (Target_Comp_Type);
Target_Index : Node_Id;
Target_Index_Type : Entity_Id;
begin
-- Error if wrong number of dimensions
if
Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type)
then
Error_Msg_N
("incompatible number of dimensions for conversion", Operand);
return False;
-- Number of dimensions matches
else
-- Loop through indexes of the two arrays
Target_Index := First_Index (Target_Type);
Opnd_Index := First_Index (Opnd_Type);
while Present (Target_Index) and then Present (Opnd_Index) loop
Target_Index_Type := Etype (Target_Index);
Opnd_Index_Type := Etype (Opnd_Index);
-- Error if index types are incompatible
if not (Is_Integer_Type (Target_Index_Type)
and then Is_Integer_Type (Opnd_Index_Type))
and then (Root_Type (Target_Index_Type)
/= Root_Type (Opnd_Index_Type))
then
Error_Msg_N
("incompatible index types for array conversion",
Operand);
return False;
end if;
Next_Index (Target_Index);
Next_Index (Opnd_Index);
end loop;
-- If component types have same base type, all set
if Target_Comp_Base = Opnd_Comp_Base then
null;
-- Here if base types of components are not the same. The only
-- time this is allowed is if we have anonymous access types.
-- The conversion of arrays of anonymous access types can lead
-- to dangling pointers. AI-392 formalizes the accessibility
-- checks that must be applied to such conversions to prevent
-- out-of-scope references.
elsif
(Ekind (Target_Comp_Base) = E_Anonymous_Access_Type
or else
Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type)
and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
and then
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
then
if Type_Access_Level (Target_Type) <
Type_Access_Level (Opnd_Type)
then
if In_Instance_Body then
Error_Msg_N ("?source array type " &
"has deeper accessibility level than target", Operand);
Error_Msg_N ("\?Program_Error will be raised at run time",
Operand);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
return False;
-- Conversion not allowed because of accessibility levels
else
Error_Msg_N ("source array type " &
"has deeper accessibility level than target", Operand);
return False;
end if;
else
null;
end if;
-- All other cases where component base types do not match
else
Error_Msg_N
("incompatible component types for array conversion",
Operand);
return False;
end if;
-- Check that component subtypes statically match
if Is_Constrained (Target_Comp_Type) /=
Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
return False;
end if;
end if;
return True;
end Valid_Array_Conversion;
----------------------------- -----------------------------
-- Valid_Tagged_Conversion -- -- Valid_Tagged_Conversion --
----------------------------- -----------------------------
...@@ -7310,6 +7649,11 @@ package body Sem_Res is ...@@ -7310,6 +7649,11 @@ package body Sem_Res is
elsif Is_Interface (Target_Type) then elsif Is_Interface (Target_Type) then
return True; return True;
elsif Is_Access_Type (Opnd_Type)
and then Is_Interface (Directly_Designated_Type (Opnd_Type))
then
return True;
else else
Error_Msg_NE Error_Msg_NE
("invalid tagged conversion, not compatible with}", ("invalid tagged conversion, not compatible with}",
...@@ -7392,10 +7736,10 @@ package body Sem_Res is ...@@ -7392,10 +7736,10 @@ package body Sem_Res is
Error_Msg_N ("ambiguous operand in conversion", Operand); Error_Msg_N ("ambiguous operand in conversion", Operand);
Error_Msg_Sloc := Sloc (It.Nam); Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("possible interpretation#!", Operand); Error_Msg_N ("\\possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1); Error_Msg_Sloc := Sloc (N1);
Error_Msg_N ("possible interpretation#!", Operand); Error_Msg_N ("\\possible interpretation#!", Operand);
return False; return False;
end if; end if;
...@@ -7406,27 +7750,40 @@ package body Sem_Res is ...@@ -7406,27 +7750,40 @@ package body Sem_Res is
end; end;
end if; end if;
if Chars (Current_Scope) = Name_Unchecked_Conversion then -- Numeric types
-- This check is dubious, what if there were a user defined if Is_Numeric_Type (Target_Type) then
-- scope whose name was Unchecked_Conversion ???
return True; -- A universal fixed expression can be converted to any numeric type
elsif Is_Numeric_Type (Target_Type) then
if Opnd_Type = Universal_Fixed then if Opnd_Type = Universal_Fixed then
return True; return True;
elsif (In_Instance or else In_Inlined_Body) -- Also no need to check when in an instance or inlined body, because
and then not Comes_From_Source (N) -- the legality has been established when the template was analyzed.
then -- Furthermore, numeric conversions may occur where only a private
return True; -- view of the operand type is visible at the instanciation point.
-- This results in a spurious error if we check that the operand type
-- is a numeric type.
-- Note: in a previous version of this unit, the following tests were
-- applied only for generated code (Comes_From_Source set to False),
-- but in fact the test is required for source code as well, since
-- this situation can arise in source code.
elsif In_Instance or else In_Inlined_Body then
return True;
-- Otherwise we need the conversion check
else else
return Conversion_Check (Is_Numeric_Type (Opnd_Type), return Conversion_Check
"illegal operand for numeric conversion"); (Is_Numeric_Type (Opnd_Type),
"illegal operand for numeric conversion");
end if; end if;
-- Array types
elsif Is_Array_Type (Target_Type) then elsif Is_Array_Type (Target_Type) then
if not Is_Array_Type (Opnd_Type) if not Is_Array_Type (Opnd_Type)
or else Opnd_Type = Any_Composite or else Opnd_Type = Any_Composite
...@@ -7435,91 +7792,15 @@ package body Sem_Res is ...@@ -7435,91 +7792,15 @@ package body Sem_Res is
Error_Msg_N Error_Msg_N
("illegal operand for array conversion", Operand); ("illegal operand for array conversion", Operand);
return False; return False;
elsif Number_Dimensions (Target_Type) /=
Number_Dimensions (Opnd_Type)
then
Error_Msg_N
("incompatible number of dimensions for conversion", Operand);
return False;
else else
declare return Valid_Array_Conversion;
Target_Index : Node_Id := First_Index (Target_Type);
Opnd_Index : Node_Id := First_Index (Opnd_Type);
Target_Index_Type : Entity_Id;
Opnd_Index_Type : Entity_Id;
Target_Comp_Type : constant Entity_Id :=
Component_Type (Target_Type);
Opnd_Comp_Type : constant Entity_Id :=
Component_Type (Opnd_Type);
begin
while Present (Target_Index) and then Present (Opnd_Index) loop
Target_Index_Type := Etype (Target_Index);
Opnd_Index_Type := Etype (Opnd_Index);
if not (Is_Integer_Type (Target_Index_Type)
and then Is_Integer_Type (Opnd_Index_Type))
and then (Root_Type (Target_Index_Type)
/= Root_Type (Opnd_Index_Type))
then
Error_Msg_N
("incompatible index types for array conversion",
Operand);
return False;
end if;
Next_Index (Target_Index);
Next_Index (Opnd_Index);
end loop;
declare
BT : constant Entity_Id := Base_Type (Target_Comp_Type);
BO : constant Entity_Id := Base_Type (Opnd_Comp_Type);
begin
if BT = BO then
null;
elsif
(Ekind (BT) = E_Anonymous_Access_Type
or else Ekind (BT) = E_Anonymous_Access_Subprogram_Type)
and then Ekind (BO) = Ekind (BT)
and then Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
null;
else
Error_Msg_N
("incompatible component types for array conversion",
Operand);
return False;
end if;
end;
if Is_Constrained (Target_Comp_Type) /=
Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
return False;
end if;
end;
end if; end if;
return True; -- Anonymous access types where target references an interface
-- Ada 2005 (AI-251)
elsif (Ekind (Target_Type) = E_General_Access_Type elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type) or else
Ekind (Target_Type) = E_Anonymous_Access_Type)
and then Is_Interface (Directly_Designated_Type (Target_Type)) and then Is_Interface (Directly_Designated_Type (Target_Type))
then then
-- Check the static accessibility rule of 4.6(17). Note that the -- Check the static accessibility rule of 4.6(17). Note that the
...@@ -7602,6 +7883,8 @@ package body Sem_Res is ...@@ -7602,6 +7883,8 @@ package body Sem_Res is
return True; return True;
-- General and anonymous access types
elsif (Ekind (Target_Type) = E_General_Access_Type elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type) or else Ekind (Target_Type) = E_Anonymous_Access_Type)
and then and then
...@@ -7742,6 +8025,8 @@ package body Sem_Res is ...@@ -7742,6 +8025,8 @@ package body Sem_Res is
end if; end if;
end; end;
-- Subprogram access types
elsif (Ekind (Target_Type) = E_Access_Subprogram_Type elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
or else or else
Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type) Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
...@@ -7792,6 +8077,8 @@ package body Sem_Res is ...@@ -7792,6 +8077,8 @@ package body Sem_Res is
return True; return True;
-- Remote subprogram access types
elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
then then
...@@ -7807,6 +8094,8 @@ package body Sem_Res is ...@@ -7807,6 +8094,8 @@ package body Sem_Res is
N); N);
return True; return True;
-- Tagged types
elsif Is_Tagged_Type (Target_Type) then elsif Is_Tagged_Type (Target_Type) then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type); return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
......
gcc/ada/sem_res.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -114,8 +114,7 @@ package Sem_Res is ...@@ -114,8 +114,7 @@ package Sem_Res is
-- read the spec of Sem. -- read the spec of Sem.
procedure Pre_Analyze_And_Resolve (N : Node_Id); procedure Pre_Analyze_And_Resolve (N : Node_Id);
-- Same, but use type of node because context does not impose a single -- Same, but use type of node because context does not impose a single type
-- type.
private private
procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve;
......
gcc/ada/types.ads
...@@ -106,10 +106,11 @@ package Types is ...@@ -106,10 +106,11 @@ package Types is
subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR;
-- Line terminator characters (LF, VT, FF, CR) -- Line terminator characters (LF, VT, FF, CR)
--
-- This definition is dubious now that we have two more wide character -- This definition is dubious now that we have two more wide character
-- sequences that constitute a line terminator. Every reference to -- sequences that constitute a line terminator. Every reference to
-- this subtype needs checking to make sure the wide character case -- this subtype needs checking to make sure the wide character case
-- is handled appropriately. -- is handled appropriately. ???
subtype Upper_Half_Character is subtype Upper_Half_Character is
Character range Character'Val (16#80#) .. Character'Val (16#FF#); Character range Character'Val (16#80#) .. Character'Val (16#FF#);
...@@ -206,7 +207,7 @@ package Types is ...@@ -206,7 +207,7 @@ package Types is
No_Location : constant Source_Ptr := -1; No_Location : constant Source_Ptr := -1;
-- Value used to indicate no source position set in a node. A test for -- Value used to indicate no source position set in a node. A test for
-- a Source_Ptr value being >= No_Location is the apporoved way to test -- a Source_Ptr value being > No_Location is the approved way to test
-- for a standard value that does not include No_Location or any of the -- for a standard value that does not include No_Location or any of the
-- following special definitions. -- following special definitions.
...@@ -683,9 +684,10 @@ package Types is ...@@ -683,9 +684,10 @@ package Types is
-- Types used for Pragma Suppress Management -- -- Types used for Pragma Suppress Management --
----------------------------------------------- -----------------------------------------------
type Check_Id is ( type Check_Id is
Access_Check, (Access_Check,
Accessibility_Check, Accessibility_Check,
Alignment_Check,
Discriminant_Check, Discriminant_Check,
Division_Check, Division_Check,
Elaboration_Check, Elaboration_Check,
...@@ -695,6 +697,7 @@ package Types is ...@@ -695,6 +697,7 @@ package Types is
Range_Check, Range_Check,
Storage_Check, Storage_Check,
Tag_Check, Tag_Check,
Validity_Check,
All_Checks); All_Checks);
-- The following array contains an entry for each recognized check name -- The following array contains an entry for each recognized check name
...@@ -804,23 +807,23 @@ package Types is ...@@ -804,23 +807,23 @@ package Types is
PE_Access_Before_Elaboration, -- 14 PE_Access_Before_Elaboration, -- 14
PE_Accessibility_Check_Failed, -- 15 PE_Accessibility_Check_Failed, -- 15
PE_All_Guards_Closed, -- 16 PE_All_Guards_Closed, -- 16
PE_Duplicated_Entry_Address, -- 17 PE_Current_Task_In_Entry_Body, -- 17
PE_Explicit_Raise, -- 18 PE_Duplicated_Entry_Address, -- 18
PE_Finalize_Raised_Exception, -- 19 PE_Explicit_Raise, -- 19
PE_Implicit_Return, -- 20 PE_Finalize_Raised_Exception, -- 20
PE_Misaligned_Address_Value, -- 21 PE_Implicit_Return, -- 21
PE_Missing_Return, -- 22 PE_Misaligned_Address_Value, -- 22
PE_Overlaid_Controlled_Object, -- 23 PE_Missing_Return, -- 23
PE_Potentially_Blocking_Operation, -- 24 PE_Overlaid_Controlled_Object, -- 24
PE_Stubbed_Subprogram_Called, -- 25 PE_Potentially_Blocking_Operation, -- 25
PE_Unchecked_Union_Restriction, -- 26 PE_Stubbed_Subprogram_Called, -- 26
PE_Illegal_RACW_E_4_18, -- 27 PE_Unchecked_Union_Restriction, -- 27
PE_Illegal_RACW_E_4_18, -- 28
SE_Empty_Storage_Pool, -- 28
SE_Explicit_Raise, -- 29 SE_Empty_Storage_Pool, -- 29
SE_Infinite_Recursion, -- 30 SE_Explicit_Raise, -- 30
SE_Object_Too_Large, -- 31 SE_Infinite_Recursion, -- 31
SE_Restriction_Violation); -- 32 SE_Object_Too_Large); -- 32
subtype RT_CE_Exceptions is RT_Exception_Code range subtype RT_CE_Exceptions is RT_Exception_Code range
CE_Access_Check_Failed .. CE_Access_Check_Failed ..
...@@ -832,6 +835,6 @@ package Types is ...@@ -832,6 +835,6 @@ package Types is
subtype RT_SE_Exceptions is RT_Exception_Code range subtype RT_SE_Exceptions is RT_Exception_Code range
SE_Empty_Storage_Pool .. SE_Empty_Storage_Pool ..
SE_Restriction_Violation; SE_Object_Too_Large;
end Types; end Types;
gcc/ada/types.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* Copyright (C) 1992-2005, Free Software Foundation, Inc. * * Copyright (C) 1992-2006, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -348,22 +348,22 @@ typedef Int Mechanism_Type; ...@@ -348,22 +348,22 @@ typedef Int Mechanism_Type;
#define PE_Access_Before_Elaboration 14 #define PE_Access_Before_Elaboration 14
#define PE_Accessibility_Check_Failed 15 #define PE_Accessibility_Check_Failed 15
#define PE_All_Guards_Closed 16 #define PE_All_Guards_Closed 16
#define PE_Duplicated_Entry_Address 17 #define PE_Current_Task_In_Entry_Body 17
#define PE_Explicit_Raise 18 #define PE_Duplicated_Entry_Address 18
#define PE_Finalize_Raised_Exception 19 #define PE_Explicit_Raise 19
#define PE_Implicit_Return 20 #define PE_Finalize_Raised_Exception 20
#define PE_Misaligned_Address_Value 21 #define PE_Implicit_Return 21
#define PE_Missing_Return 22 #define PE_Misaligned_Address_Value 22
#define PE_Overlaid_Controlled_Object 23 #define PE_Missing_Return 23
#define PE_Potentially_Blocking_Operation 24 #define PE_Overlaid_Controlled_Object 24
#define PE_Stubbed_Subprogram_Called 25 #define PE_Potentially_Blocking_Operation 25
#define PE_Unchecked_Union_Restriction 26 #define PE_Stubbed_Subprogram_Called 26
#define PE_Illegal_RACW_E_4_18 27 #define PE_Unchecked_Union_Restriction 27
#define PE_Illegal_RACW_E_4_18 28
#define SE_Empty_Storage_Pool 28
#define SE_Explicit_Raise 29 #define SE_Empty_Storage_Pool 29
#define SE_Infinite_Recursion 30 #define SE_Explicit_Raise 30
#define SE_Object_Too_Large 31 #define SE_Infinite_Recursion 31
#define SE_Restriction_Violation 32 #define SE_Object_Too_Large 32
#define LAST_REASON_CODE 31 #define LAST_REASON_CODE 32
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