Commit b6dd03dd by Ed Schonberg Committed by Arnaud Charlet

sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function…

sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function call, return True if type is class-wide.

2015-01-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity
	or a function call, return True if type is class-wide.
	* sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression);
	Apply RM 4.5.7 (17/3): all or none of the dependent expression
	of a conditional expression must be dynamically tagged.

From-SVN: r220276
parent 566d377a
2015-01-30 Ed Schonberg <schonberg@adacore.com>
* sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity
or a function call, return True if type is class-wide.
* sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression);
Apply RM 4.5.7 (17/3): all or none of the dependent expression
of a conditional expression must be dynamically tagged.
2015-01-30 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): In an extended return
statement, apply accessibility check to result object when there
is no initializing expression (Ada 2012 RM 6.5 (5.4/3))
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -562,6 +562,12 @@ package body Sem_Disp is
then
null;
elsif Ekind (Current_Scope) = E_Function
and then Nkind (Unit_Declaration_Node (Current_Scope))
= N_Generic_Subprogram_Declaration
then
null;
else
-- We need to determine whether the context of the call
-- provides a tag to make the call dispatching. This requires
......@@ -2162,8 +2168,24 @@ package body Sem_Disp is
begin
if Nkind (N) = N_Error then
return False;
elsif Present (Find_Controlling_Arg (N)) then
return True;
-- Special cases : entities, and calls that dispatch on result.
elsif Is_Entity_Name (N) then
return Is_Class_Wide_Type (Etype (N));
elsif Nkind (N) = N_Function_Call
and then Is_Class_Wide_Type (Etype (N))
then
return True;
-- Otherwise check whether call has controlling argument.
else
return Find_Controlling_Arg (N) /= Empty;
return False;
end if;
end Is_Dynamically_Tagged;
......
......@@ -6416,7 +6416,8 @@ package body Sem_Res is
-----------------------------
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
Alt : Node_Id;
Alt : Node_Id;
Is_Dyn : Boolean;
begin
Alt := First (Alternatives (N));
......@@ -6425,6 +6426,23 @@ package body Sem_Res is
Next (Alt);
end loop;
-- Apply RM 4.5.7 (17/3): whether the expression is statically or
-- dynamically tagged must be known statically.
if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
Alt := First (Alternatives (N));
Is_Dyn := Is_Dynamically_Tagged (Expression (Alt));
while Present (Alt) loop
if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then
Error_Msg_N ("all or none of the dependent expressions "
& "can be dynamically tagged", N);
end if;
Next (Alt);
end loop;
end if;
Set_Etype (N, Typ);
Eval_Case_Expression (N);
end Resolve_Case_Expression;
......@@ -8061,11 +8079,20 @@ package body Sem_Res is
Resolve (Else_Expr, Typ);
Else_Typ := Etype (Else_Expr);
if Is_Scalar_Type (Else_Typ)
and then Else_Typ /= Typ
then
if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then
Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
Analyze_And_Resolve (Else_Expr, Typ);
-- Apply RM 4.5.7 (17/3): whether the expression is statically or
-- dynamically tagged must be known statically.
elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
if Is_Dynamically_Tagged (Then_Expr) /=
Is_Dynamically_Tagged (Else_Expr)
then
Error_Msg_N ("all or none of the dependent expressions "
& "can be dynamically tagged", N);
end if;
end if;
-- If no ELSE expression is present, root type must be Standard.Boolean
......@@ -8232,10 +8259,10 @@ package body Sem_Res is
(Entity (Prefix (N)))))
and then not Is_Atomic (Component_Type (Array_Type))
then
Error_Msg_N ("??access to non-atomic component of atomic array",
Prefix (N));
Error_Msg_N ("??\may cause unexpected accesses to atomic object",
Prefix (N));
Error_Msg_N
("??access to non-atomic component of atomic array", Prefix (N));
Error_Msg_N
("??\may cause unexpected accesses to atomic object", Prefix (N));
end if;
end Resolve_Indexed_Component;
......@@ -8263,9 +8290,14 @@ package body Sem_Res is
-- If the operand is a literal, it cannot be the expression in a
-- conversion. Use a qualified expression instead.
---------------------
-- Convert_Operand --
---------------------
function Convert_Operand (Opnd : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Opnd);
Res : Node_Id;
begin
if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
Res :=
......@@ -8309,8 +8341,6 @@ package body Sem_Res is
or else Is_Private_Type (Etype (Right_Opnd (N)))
then
Arg1 := Convert_Operand (Left_Opnd (N));
-- Unchecked_Convert_To (Btyp, Left_Opnd (N));
-- What on earth is this commented out fragment of code???
if Nkind (N) = N_Op_Expon then
Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
......
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