Skip to content

R
riscv-gcc-1
Commit 8e4dac80 by Thomas Quinot Committed by Arnaud Charlet
Options

sem_res.adb, [...]: Minor reformatting. 

2010-10-21  Thomas Quinot  <quinot@adacore.com>

	* sem_res.adb, exp_ch13.adb: Minor reformatting.

2010-10-21  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt
	to provide a tagged full view as the completion of an untagged partial
	view if the partial view has a discriminant with default.

From-SVN: r165775
parent 77a74ed7
Showing with 78 additions and 35 deletions
gcc/ada/ChangeLog
2010-10-21 Thomas Quinot <quinot@adacore.com>
* sem_res.adb, exp_ch13.adb: Minor reformatting.
2010-10-21 Thomas Quinot <quinot@adacore.com>
* sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt
to provide a tagged full view as the completion of an untagged partial
view if the partial view has a discriminant with default.
2010-10-21 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies.
......
gcc/ada/exp_ch13.adb
......@@ -105,8 +105,8 @@ package body Exp_Ch13 is
-- is build by connecting the component predicates with AND THEN.
procedure Add_Call (T : Entity_Id);
-- Includes a call statement to the predicate function for type T in
-- Expr if T has predicates and Predicate_Function (T) is non-empty.
-- Includes a call to the predicate function for type T in Expr if T
-- has predicates and Predicate_Function (T) is non-empty.
procedure Add_Predicates;
-- Appends expressions for any Predicate pragmas in the rep item chain
......@@ -125,15 +125,12 @@ package body Exp_Ch13 is
Exp : Node_Id;
begin
if Present (T)
and then Present (Predicate_Function (T))
then
if Present (T) and then Present (Predicate_Function (T)) then
Exp :=
Make_Predicate_Call
(T,
Convert_To (T,
Make_Identifier (Loc,
Chars => Object_Name)));
Make_Identifier (Loc, Chars => Object_Name)));
if No (Expr) then
Expr := Exp;
......@@ -170,9 +167,8 @@ package body Exp_Ch13 is
begin
-- Case of entity name referencing the type
if Is_Entity_Name (N)
and then Entity (N) = Typ
then
if Is_Entity_Name (N) and then Entity (N) = Typ then
-- Replace with object
Rewrite (N,
......@@ -183,13 +179,15 @@ package body Exp_Ch13 is
return Skip;
-- Not an instance of the type entity, keep going
-- Not an occurrence of the type entity, keep going
else
return OK;
end if;
end Replace_Node;
-- Start of processing for Add_Predicates
begin
Ritem := First_Rep_Item (Typ);
while Present (Ritem) loop
......@@ -208,7 +206,7 @@ package body Exp_Ch13 is
-- looking for the type entity, doing the needed substitution.
-- The preanalysis is done with the special OK_To_Reference
-- flag set on the type, so that if we get an occurrence of
-- this type, it will be reognized as legitimate.
-- this type, it will be recognized as legitimate.
Set_OK_To_Reference (Typ, True);
Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
......@@ -241,7 +239,7 @@ package body Exp_Ch13 is
begin
-- Initialize for construction of statement list
Expr := Empty;
Expr := Empty;
FDecl := Empty;
FBody := Empty;
......@@ -289,6 +287,7 @@ package body Exp_Ch13 is
loop
Elmt := First_Elmt (Iface_List);
exit when No (Elmt);
Add_Call (Node (Elmt));
Remove_Elmt (Iface_List, Elmt);
end loop;
......@@ -313,10 +312,8 @@ package body Exp_Ch13 is
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Object_Name),
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type => New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
......@@ -336,8 +333,7 @@ package body Exp_Ch13 is
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Object_Name),
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
......@@ -737,7 +733,7 @@ package body Exp_Ch13 is
end;
end if;
-- Pop scope if we intalled one for the analysis
-- Pop scope if we installed one for the analysis
if In_Other_Scope then
if Ekind (Current_Scope) = E_Package then
......
gcc/ada/sem_ch3.adb
......@@ -284,9 +284,11 @@ package body Sem_Ch3 is
(N : Node_Id;
T : Entity_Id;
Prev : Entity_Id := Empty);
-- If T is the full declaration of an incomplete or private type, check the
-- conformance of the discriminants, otherwise process them. Prev is the
-- entity of the partial declaration, if any.
-- If N is the full declaration of the completion T of an incomplete or
-- private type, check its discriminants (which are already known to be
-- conformant with those of the partial view, see Find_Type_Name),
-- otherwise process them. Prev is the entity of the partial declaration,
-- if any.
procedure Check_Real_Bound (Bound : Node_Id);
-- Check given bound for being of real type and static. If not, post an
......@@ -9589,7 +9591,9 @@ package body Sem_Ch3 is
-- If an incomplete or private type declaration was already given for the
-- type, the discriminants may have already been processed if they were
-- present on the incomplete declaration. In this case a full conformance
-- check is performed otherwise just process them.
-- check has been performed in Find_Type_Name, and we then recheck here
-- some properties that can't be checked on the partial view alone.
-- Otherwise we call Process_Discriminants.
procedure Check_Or_Process_Discriminants
(N : Node_Id;
......@@ -9599,19 +9603,46 @@ package body Sem_Ch3 is
begin
if Has_Discriminants (T) then
-- Make the discriminants visible to component declarations
-- Discriminants are already set on T if they were already present
-- on the partial view. Make them visible to component declarations.
declare
D : Entity_Id;
Prev : Entity_Id;
-- Discriminant on T (full view) referencing expression on partial
-- view.
Prev_D : Entity_Id;
-- Entity of corresponding discriminant on partial view
New_D : Node_Id;
-- Discriminant specification for full view, expression is the
-- syntactic copy on full view (which has been checked for
-- conformance with partial view), only used here to post error
-- message.
begin
D := First_Discriminant (T);
New_D := First (Discriminant_Specifications (N));
while Present (D) loop
Prev := Current_Entity (D);
Prev_D := Current_Entity (D);
Set_Current_Entity (D);
Set_Is_Immediately_Visible (D);
Set_Homonym (D, Prev);
Set_Homonym (D, Prev_D);
-- Handle the case where there is an untagged partial view and
-- the full view is tagged: must disallow discriminants with
-- defaults. However suppress the error here if it was already
-- reported on the default expression of the partial view.
if Is_Tagged_Type (T)
and then Present (Expression (Parent (D)))
and then not Error_Posted (Expression (Parent (D)))
then
Error_Msg_N
("discriminants of tagged type "
& "cannot have defaults",
Expression (New_D));
end if;
-- Ada 2005 (AI-230): Access discriminant allowed in
-- non-limited record types.
......@@ -9625,6 +9656,7 @@ package body Sem_Ch3 is
end if;
Next_Discriminant (D);
Next (New_D);
end loop;
end;
......@@ -16354,13 +16386,18 @@ package body Sem_Ch3 is
("discriminant defaults not allowed for formal type",
Expression (Discr));
-- Tagged types declarations cannot have defaulted discriminants,
-- but an untagged private type with defaulted discriminants can
-- have a tagged completion.
elsif Is_Tagged_Type (Current_Scope)
and then Comes_From_Source (N)
and then Comes_From_Source (N)
then
-- Note: see also similar test in Check_Or_Process_
-- Discriminants, to handle the (illegal) case of the
-- completion of an untagged view with discriminants
-- with defaults by a tagged full view. We skip the check if
-- Discr does not come from source to account for the case of
-- an untagged derived type providing defaults for a renamed
-- discriminant from a private nontagged ancestor with a tagged
-- full view (ACATS B460006).
Error_Msg_N
("discriminants of tagged type cannot have defaults",
Expression (Discr));
......
gcc/ada/sem_res.adb
......@@ -3848,8 +3848,8 @@ package body Sem_Res is
Eval_Actual (A);
-- If it is a named association, treat the selector_name as
-- a proper identifier, and mark the corresponding entity.
-- If it is a named association, treat the selector_name as a
-- proper identifier, and mark the corresponding entity.
if Nkind (Parent (A)) = N_Parameter_Association then
Set_Entity (Selector_Name (Parent (A)), F);
......
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