Skip to content

R
riscv-gcc-1
Commit a73734f5 by Arnaud Charlet
Options

[multiple changes] 

2009-07-29  Robert Dewar  <dewar@adacore.com>

	* exp_atag.ads, exp_atag.adb, s-tasini.adb, s-soflin.ads,
	exp_disp.adb, g-socket.adb: Minor reformatting

2009-07-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch7.adb (New_Private_Type): Create class-wide type after other
	attributes have been established, so that they are all inherited by the
	class-wide type.
	* sem_cat.adb (Validate_Remote_Access_Object_Type_Declaration): Handle
	properly named subtypes of class-wide types.

From-SVN: r150201
parent 53b10ce9
Showing with 53 additions and 34 deletions
gcc/ada/ChangeLog
2009-07-29 Robert Dewar <dewar@adacore.com>
* exp_atag.ads, exp_atag.adb, s-tasini.adb, s-soflin.ads,
exp_disp.adb, g-socket.adb: Minor reformatting
2009-07-29 Ed Schonberg <schonberg@adacore.com>
* sem_ch7.adb (New_Private_Type): Create class-wide type after other
attributes have been established, so that they are all inherited by the
class-wide type.
* sem_cat.adb (Validate_Remote_Access_Object_Type_Declaration): Handle
properly named subtypes of class-wide types.
2009-07-29 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Check_Overriding_Indicator): Handle properly overriding
......
gcc/ada/exp_atag.adb
......@@ -231,7 +231,7 @@ package body Exp_Atag is
(Loc : Source_Ptr;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id)
New_Node : out Node_Id)
is
Ctrl_Tag : Node_Id;
......@@ -352,7 +352,7 @@ package body Exp_Atag is
Typ : Entity_Id;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id)
New_Node : out Node_Id)
is
New_Prefix : Node_Id;
......
gcc/ada/exp_atag.ads
......@@ -65,7 +65,7 @@ package Exp_Atag is
(Loc : Source_Ptr;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id);
New_Node : out Node_Id);
-- Given a pointer to a dispatch table (T) and a position in the DT, build
-- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls). Tag_Node is relocated.
......@@ -77,7 +77,7 @@ package Exp_Atag is
Typ : Entity_Id;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id);
New_Node : out Node_Id);
-- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls).
-- Tag_Node is relocated.
......
gcc/ada/exp_disp.adb
......@@ -811,11 +811,11 @@ package body Exp_Disp is
else
Controlling_Tag :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
end if;
-- Handle dispatching calls to predefined primitives.
-- Handle dispatching calls to predefined primitives
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
......@@ -854,10 +854,10 @@ package body Exp_Disp is
-- Handle renaming of selected component
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind (Parent (Entity (Controlling_Tag)))
= N_Object_Renaming_Declaration
and then Nkind (Name (Parent (Entity (Controlling_Tag))))
= N_Selected_Component
and then Nkind (Parent (Entity (Controlling_Tag))) =
N_Object_Renaming_Declaration
and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
N_Selected_Component
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Name (Parent (Entity (Controlling_Tag))));
......@@ -867,8 +867,8 @@ package body Exp_Disp is
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind_In (Parent (Entity (Controlling_Tag)),
N_Object_Declaration,
N_Parameter_Specification)
N_Object_Declaration,
N_Parameter_Specification)
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Controlling_Tag)));
......@@ -879,8 +879,8 @@ package body Exp_Disp is
elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
N_Object_Declaration,
N_Parameter_Specification)
N_Object_Declaration,
N_Parameter_Specification)
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Prefix (Controlling_Tag))));
......@@ -894,9 +894,9 @@ package body Exp_Disp is
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent
(Node
(First_Elmt
(Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
(Node
(First_Elmt
(Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
-- Interfaces are not supported. For now we leave the SCIL node
-- decorated with the Controlling_Tag. More work needed here???
......@@ -913,7 +913,7 @@ package body Exp_Disp is
if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
Name => New_Call_Name,
Name => New_Call_Name,
Parameter_Associations => New_Params);
-- If this is a dispatching "=", we must first compare the tags so
......@@ -927,26 +927,26 @@ package body Exp_Disp is
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Value (Param),
Prefix => New_Value (Param),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ),
Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Prefix =>
Unchecked_Convert_To (Typ,
New_Value (Next_Actual (Param))),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ),
Loc))),
New_Reference_To
(First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
end if;
else
New_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Call_Name,
Name => New_Call_Name,
Parameter_Associations => New_Params);
end if;
......
gcc/ada/g-socket.adb
......@@ -1664,11 +1664,14 @@ package body GNAT.Sockets is
(Msg_Name => System.Null_Address,
Msg_Namelen => 0,
Msg_Iov => Vector'Address,
Msg_Iovlen =>
SOSC.Msg_Iovlen_T'Min (Vector'Length, SOSC.IOV_MAX),
-- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
-- platforms) when the supplied vector is longer than IOV_MAX,
-- so use minimum of the two lengths.
Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
(Vector'Length, SOSC.IOV_MAX),
Msg_Control => System.Null_Address,
Msg_Controllen => 0,
Msg_Flags => 0);
......
gcc/ada/s-soflin.ads
......@@ -242,7 +242,7 @@ package System.Soft_Links is
function Get_Exc_Stack_Addr_NT return Address;
Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
function Get_Current_Excep_NT return EOA;
function Get_Current_Excep_NT return EOA;
Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
......
gcc/ada/s-tasini.adb
......@@ -191,8 +191,8 @@ package body System.Tasking.Initialization is
end if;
-- pragma Assert
-- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
-- Self_ID.Deferral_Level > 0));
-- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
-- Self_ID.Deferral_Level > 0);
-- See comment in Defer_Abort on the situations in which it may be
-- useful to uncomment the above assertion.
......
gcc/ada/sem_cat.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2009, 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- --
......@@ -1774,12 +1774,12 @@ package body Sem_Cat is
-- Check RCI or RT unit type declaration. It may not contain the
-- declaration of an access-to-object type unless it is a general access
-- type that designates a class-wide limited private type. There are
-- also constraints on the primitive subprograms of the class-wide type
-- (RM E.2.2(14), see Validate_RACW_Primitives).
-- type that designates a class-wide limited private type or subtype.
-- There are also constraints on the primitive subprograms of the
-- class-wide type (RM E.2.2(14), see Validate_RACW_Primitives).
if Ekind (T) /= E_General_Access_Type
or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type
or else not Is_Class_Wide_Type (Designated_Type (T))
then
if In_RCI_Declaration (Parent (T)) then
Error_Msg_N
......
gcc/ada/sem_ch7.adb
......@@ -1907,12 +1907,15 @@ package body Sem_Ch7 is
if Tagged_Present (Def) then
Set_Ekind (Id, E_Record_Type_With_Private);
Make_Class_Wide_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
Set_Is_Abstract_Type (Id, Abstract_Present (Def));
Set_Is_Limited_Record (Id, Limited_Present (Def));
Set_Has_Delayed_Freeze (Id, True);
-- Create a class-wide type with the same attributes.
Make_Class_Wide_Type (Id);
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
end if;
......
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