Skip to content

R
riscv-gcc-1
Commit 22cb89b5 by Arnaud Charlet
Options

[multiple changes] 

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is
	the class-wide type for a private extension, and the completion is a
	subtype, set the type of the class-wide type to the base type of the
	full view.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb,
	sem_intr.adb, sem_eval.adb: Minor reformatting

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Is_Ancestor): If either type is private, examine full
	view.

From-SVN: r160966
parent e9672ebe
Showing with 78 additions and 31 deletions
gcc/ada/ChangeLog
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is
the class-wide type for a private extension, and the completion is a
subtype, set the type of the class-wide type to the base type of the
full view.
2010-06-18 Robert Dewar <dewar@adacore.com>
* g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb,
sem_intr.adb, sem_eval.adb: Minor reformatting
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* sem_type.adb (Is_Ancestor): If either type is private, examine full
view.
2010-06-18 Thomas Quinot <quinot@adacore.com>
* g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN
......
gcc/ada/einfo.ads
......@@ -6189,7 +6189,7 @@ package Einfo is
-- have an RM_Size value of zero).
-- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one
-- more consideration, which is that we always return false for generic
-- more consideration, which is that we always return False for generic
-- types. Within a template, the size can look known, because of the fake
-- size values we put in template types, but they are not really known and
-- anyone testing if they are known within the template should get False as
......
gcc/ada/exp_util.adb
......@@ -3475,7 +3475,7 @@ package body Exp_Util is
-- Generate warning if not suppressed
if W then
Error_Msg_F
Error_Msg_F -- CODEFIX???
("?this code can never be executed and has been deleted!", N);
end if;
end if;
......@@ -4052,6 +4052,20 @@ package body Exp_Util is
-- additional intermediate type to handle the assignment).
if Expander_Active and then Tagged_Type_Expansion then
-- If this is the class_wide type of a completion that is
-- a record subtype, set the type of the class_wide type
-- to be the full base type, for use in the expanded code
-- for the equivalent type. Should this be done earlier when
-- the completion is analyzed ???
if Is_Private_Type (Etype (Unc_Typ))
and then
Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
then
Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
end if;
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
end if;
......
gcc/ada/g-socket.ads
......@@ -1088,9 +1088,11 @@ package GNAT.Sockets is
-- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was
-- ready after a Timeout expiration. Status is set to Aborted if an abort
-- signal has been received while checking socket status.
--
-- Note that two different Socket_Set_Type objects must be passed as
-- R_Socket_Set and W_Socket_Set (even if they denote the same set of
-- Sockets), or some event may be lost.
--
-- Socket_Error is raised when the select(2) system call returns an
-- error condition, or when a read error occurs on the signalling socket
-- used for the implementation of Abort_Selector.
......
gcc/ada/sem_aggr.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
......@@ -1431,7 +1431,8 @@ package body Sem_Aggr is
-- aggregate must not be enclosed in parentheses.
if Paren_Count (Expr) /= 0 then
Error_Msg_N ("no parenthesis allowed here", Expr);
Error_Msg_N -- CODEFIX???
("no parenthesis allowed here", Expr);
end if;
Make_String_Into_Aggregate (Expr);
......@@ -1443,8 +1444,9 @@ package body Sem_Aggr is
-- a missing component association for a 1-aggregate.
if Paren_Count (Expr) > 0 then
Error_Msg_N ("\if single-component aggregate is intended,"
& " write e.g. (1 ='> ...)", Expr);
Error_Msg_N -- CODEFIX???
("\if single-component aggregate is intended,"
& " write e.g. (1 ='> ...)", Expr);
end if;
return Failure;
end if;
......@@ -1547,13 +1549,13 @@ package body Sem_Aggr is
if Choice /= First (Choices (Assoc))
or else Present (Next (Choice))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("OTHERS must appear alone in a choice list", Choice);
return Failure;
end if;
if Present (Next (Assoc)) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("OTHERS must appear last in an aggregate", Choice);
return Failure;
end if;
......@@ -2504,8 +2506,8 @@ package body Sem_Aggr is
-- New_Assoc_List the discriminant value specified in the ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed, The inherited discriminant values must not be reinserted
-- in the component list to prevent spurious errors, but it must be
-- reanalyzed. The inherited discriminant values must not be reinserted
-- in the component list to prevent spurious errors, but they must be
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
......@@ -3023,13 +3025,15 @@ package body Sem_Aggr is
if Selector_Name /= First (Choices (Assoc))
or else Present (Next (Selector_Name))
then
Error_Msg_N ("OTHERS must appear alone in a choice list",
Selector_Name);
Error_Msg_N -- CODEFIX???
("OTHERS must appear alone in a choice list",
Selector_Name);
return;
elsif Present (Next (Assoc)) then
Error_Msg_N ("OTHERS must appear last in an aggregate",
Selector_Name);
Error_Msg_N -- CODEFIX???
("OTHERS must appear last in an aggregate",
Selector_Name);
return;
-- (Ada2005): If this is an association with a box,
......@@ -3242,10 +3246,11 @@ package body Sem_Aggr is
if Nkind (Parent (Base_Type (Root_Typ))) =
N_Private_Type_Declaration
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("type of aggregate has private ancestor&!",
N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N);
Error_Msg_N -- CODEFIX???
("must use extension aggregate!", N);
return;
end if;
......@@ -3278,10 +3283,11 @@ package body Sem_Aggr is
N_Private_Extension_Declaration
then
if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("type of aggregate has private ancestor&!",
N, Parent_Typ);
Error_Msg_N ("must use extension aggregate!", N);
Error_Msg_N -- CODEFIX???
("must use extension aggregate!", N);
return;
elsif Parent_Typ /= Root_Typ then
......@@ -3766,7 +3772,7 @@ package body Sem_Aggr is
if No (Others_Etype)
and then not Others_Box
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("OTHERS must represent at least one component", Selectr);
end if;
......
gcc/ada/sem_elim.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2010, 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- --
......@@ -295,11 +295,11 @@ package body Sem_Elim is
Up := Elmt.Unit_Name'Last;
-- If we are within a subunit, the name in the pragma has been
-- parsed as a child unit, but the current compilation unit is
-- in fact the parent in which the subunit is embedded. We must
-- skip the first name which is that of the subunit to match
-- the pragma specification.
-- If we are within a subunit, the name in the pragma has been
-- parsed as a child unit, but the current compilation unit is in
-- fact the parent in which the subunit is embedded. We must skip
-- the first name which is that of the subunit to match the pragma
-- specification.
declare
Par : Node_Id;
......
gcc/ada/sem_intr.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
......@@ -54,7 +54,7 @@ package body Sem_Intr is
procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
-- Check that operator is one of the binary arithmetic operators, and
-- that the types involved both have underlying integer types..
-- that the types involved both have underlying integer types.
procedure Check_Shift (E : Entity_Id; N : Node_Id);
-- Check intrinsic shift subprogram, the two arguments are the same
......
gcc/ada/sem_type.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
......@@ -2554,9 +2554,9 @@ package body Sem_Type is
BT1 := Base_Type (T1);
BT2 := Base_Type (T2);
-- Handle underlying view of records with unknown discriminants
-- using the original entity that motivated the construction of
-- this underlying record view (see Build_Derived_Private_Type).
-- Handle underlying view of records with unknown discriminants using
-- the original entity that motivated the construction of this
-- underlying record view (see Build_Derived_Private_Type).
if Is_Underlying_Record_View (BT1) then
BT1 := Underlying_Record_View (BT1);
......@@ -2569,12 +2569,20 @@ package body Sem_Type is
if BT1 = BT2 then
return True;
-- The predicate must look past privacy
elsif Is_Private_Type (T1)
and then Present (Full_View (T1))
and then BT2 = Base_Type (Full_View (T1))
then
return True;
elsif Is_Private_Type (T2)
and then Present (Full_View (T2))
and then BT1 = Base_Type (Full_View (T2))
then
return True;
else
Par := Etype (BT2);
......
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