+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
(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;
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;
(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.
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.
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)
-- 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))));
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)));
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))));
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???
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
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;
(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);
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;
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.
-- --
-- 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- --
-- 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
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;
OSDN Git Service
