+2009-07-20 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Check_Dynamically_Tagged_Expression): New
+ subprogram.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Check incorrect use of
+ dynamically tagged expression.
+ * sem_ch3.adb (Analyze_Object_Declaration): Call new routine that
+ factorizes code.
+ * sem_ch6.adb (Analyze_Function_Return, Process_Formals): Ditto.
+ * sem_ch8.adb (Analyze_Object_Renaming): Ditto.
+
2009-07-20 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Expander; use Expander;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
Single_Elmt => Single_Choice)
then
return Failure;
+
+ -- Check incorrect use of dynamically tagged expression
+
+ -- We differentiate here two cases because the expression may
+ -- not be decorated. For example, the analysis and resolution
+ -- of the expression associated with the others choice will
+ -- be done later with the full aggregate. In such case we
+ -- duplicate the expression tree to analyze the copy and
+ -- perform the required check.
+
+ elsif not Present (Etype (Expression (Assoc))) then
+ declare
+ Save_Analysis : constant Boolean := Full_Analysis;
+ Expr : constant Node_Id :=
+ New_Copy_Tree (Expression (Assoc));
+
+ begin
+ Expander_Mode_Save_And_Set (False);
+ Full_Analysis := False;
+ Analyze (Expr);
+ Full_Analysis := Save_Analysis;
+ Expander_Mode_Restore;
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+ end;
+
+ elsif Is_Tagged_Type (Etype (Expression (Assoc))) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expression (Assoc),
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
end if;
Next (Assoc);
return Failure;
end if;
+ -- Check incorrect use of dynamically tagged expression
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+
Next (Expr);
end loop;
Single_Elmt => False)
then
return Failure;
+
+ -- Check incorrect use of dynamically tagged expression. The
+ -- expression of the others choice has not been resolved yet.
+ -- In order to diagnose the semantic error we create a duplicate
+ -- tree to analyze it and perform the check.
+
+ else
+ declare
+ Save_Analysis : constant Boolean := Full_Analysis;
+ Expr : constant Node_Id :=
+ New_Copy_Tree (Expression (Assoc));
+
+ begin
+ Expander_Mode_Save_And_Set (False);
+ Full_Analysis := False;
+ Analyze (Expr);
+ Full_Analysis := Save_Analysis;
+ Expander_Mode_Restore;
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+ end;
end if;
end if;
end if;
end if;
- -- Check incorrect use of dynamically tagged expressions. Note
- -- the use of Is_Tagged_Type (T) which seems redundant but is in
- -- fact important to avoid spurious errors due to expanded code
- -- for dispatching functions over an anonymous access type
+ -- Check incorrect use of dynamically tagged expressions.
- if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
- and then Is_Tagged_Type (T)
- and then not Is_Class_Wide_Type (T)
- then
- Error_Msg_N ("dynamically tagged expression not allowed!", E);
+ if Is_Tagged_Type (T) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => E,
+ Typ => T,
+ Related_Nod => N);
end if;
Apply_Scalar_Range_Check (E, T);
end if;
end if;
- if (Is_Class_Wide_Type (Etype (Expr))
- or else Is_Dynamically_Tagged (Expr))
- and then not Is_Class_Wide_Type (R_Type)
- then
- Error_Msg_N
- ("dynamically tagged expression not allowed!", Expr);
+ -- Check incorrect use of dynamically tagged expression
+
+ if Is_Tagged_Type (R_Type) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => R_Type,
+ Related_Nod => N);
end if;
-- ??? A real run-time accessibility check is needed in cases
Error_Msg_N
("access to class-wide expression not allowed here", Default);
end if;
+
+ -- Check incorrect use of dynamically tagged expressions
+
+ if Is_Tagged_Type (Formal_Type) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Default,
+ Typ => Formal_Type,
+ Related_Nod => Default);
+ end if;
end if;
-- Ada 2005 (AI-231): Static checks
-- cases where the renamed object is a dynamically tagged access
-- result, such as occurs in certain expansions.
- if (Is_Class_Wide_Type (Etype (Nam))
- or else (Is_Dynamically_Tagged (Nam)
- and then not Is_Access_Type (T)))
- and then not Is_Class_Wide_Type (T)
- then
- Error_Msg_N ("dynamically tagged expression not allowed!", Nam);
+ if Is_Tagged_Type (T) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Nam,
+ Typ => T,
+ Related_Nod => N);
end if;
-- Ada 2005 (AI-230/AI-254): Access renaming
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
end if;
end Cannot_Raise_Constraint_Error;
+ -----------------------------------------
+ -- Check_Dynamically_Tagged_Expression --
+ -----------------------------------------
+
+ procedure Check_Dynamically_Tagged_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ begin
+ pragma Assert (Is_Tagged_Type (Typ));
+
+ if Comes_From_Source (Related_Nod)
+ and then (Is_Class_Wide_Type (Etype (Expr))
+ or else Is_Dynamically_Tagged (Expr))
+ and then Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+ end if;
+ end Check_Dynamically_Tagged_Expression;
+
--------------------------
-- Check_Fully_Declared --
--------------------------
-- not necessarily mean that CE could be raised, but a response of True
-- means that for sure CE cannot be raised.
+ procedure Check_Dynamically_Tagged_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Related_Nod : Node_Id);
+ -- Check wrong use of dynamically tagged expression
+
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
-- Verify that the full declaration of type T has been seen. If not,
-- place error message on node N. Used in object declarations, type
projects / platform / upstream / linaro-gcc.git / commitdiff