[multiple changes]
2009-04-20 Javier Miranda <miranda@adacore.com> * einfo.ads, einfo.adb (Is_Underlying_Record_View): New subprogram (Set_Is_Underlying_Record_View): New subprogram * sem_aggr.adb (Discr_Present, Resolve_Record_Aggregate): In case of private types with unknown discriminants use the underlying record view if available. * sem_ch3.adb (Build_Derived_Private_Type): Enable construction of the underlying record view in the full view of private types whose parent has unknown discriminants. (Build_Derived_Record_Type): Avoid generating the class-wide entity associated with an underlying record view. (Derived_Type_Declaration): Avoid deriving parent primitives in underlying record views. * sem_ch6.adb (Check_Return_Subtype_Indication): Add support for records with unknown discriminants. * sem_type.adb (Covers): Handle underlying record views. (Is_Ancestor): Add support for underlying record views. * exp_attr.adb (Expand_Attribute): Expand attribute 'size into a dispatching call if the type of the target object is tagged and has unknown discriminants. * exp_aggr.adb (Resolve_Record_Aggregate): Add support for records with unknown discriminants. * exp_disp.adb (Build_Dispatch_Tables): Avoid generating dispatch tables for internally built underlying record views. * sprint.adb (sprint_node_actual): Improve output of aggregates with an empty list of component associations. 2009-04-20 Thomas Quinot <quinot@adacore.com> * sem_ch10.adb: Minor reformatting * socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi.ads, g-socket.adb (GNAT.Sockets.Inet_Addr): Do not use non-portable inet_aton, instead use standard inet_pton API (and emulate it on platforms that do not support it). (GNAT.Sockets.Thin.Inet_Pton, VMS case): Implement in terms of DECC$INET_ADDR, imported in Ada. (GNAT.Sockets.Thin.Inet_Pton, VxWorks and Windows cases): Use C implementation provided by GNAT runtime. (__gnat_inet_pton): C implementation of inet_pton(3) for VxWorks and Windows. From-SVN: r146391
This commit is contained in:
Arnaud Charlet
parent
7289b80c09
commit
9013065bc0
@ -1,3 +1,55 @@
|
||||
2009-04-20 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* einfo.ads, einfo.adb (Is_Underlying_Record_View): New subprogram
|
||||
(Set_Is_Underlying_Record_View): New subprogram
|
||||
|
||||
* sem_aggr.adb (Discr_Present, Resolve_Record_Aggregate): In case of
|
||||
private types with unknown discriminants use the underlying record view
|
||||
if available.
|
||||
|
||||
* sem_ch3.adb (Build_Derived_Private_Type): Enable construction of the
|
||||
underlying record view in the full view of private types whose parent
|
||||
has unknown discriminants.
|
||||
(Build_Derived_Record_Type): Avoid generating the class-wide entity
|
||||
associated with an underlying record view.
|
||||
(Derived_Type_Declaration): Avoid deriving parent primitives in
|
||||
underlying record views.
|
||||
|
||||
* sem_ch6.adb (Check_Return_Subtype_Indication): Add support for
|
||||
records with unknown discriminants.
|
||||
|
||||
* sem_type.adb (Covers): Handle underlying record views.
|
||||
(Is_Ancestor): Add support for underlying record views.
|
||||
|
||||
* exp_attr.adb (Expand_Attribute): Expand attribute 'size into a
|
||||
dispatching call if the type of the target object is tagged and has
|
||||
unknown discriminants.
|
||||
|
||||
* exp_aggr.adb (Resolve_Record_Aggregate): Add support for records with
|
||||
unknown discriminants.
|
||||
|
||||
* exp_disp.adb (Build_Dispatch_Tables): Avoid generating dispatch
|
||||
tables for internally built underlying record views.
|
||||
|
||||
* sprint.adb (sprint_node_actual): Improve output of aggregates with an
|
||||
empty list of component associations.
|
||||
|
||||
2009-04-20 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sem_ch10.adb: Minor reformatting
|
||||
|
||||
* socket.c, g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.ads,
|
||||
g-socthi-mingw.ads, g-socthi.ads, g-socket.adb
|
||||
(GNAT.Sockets.Inet_Addr): Do not use non-portable inet_aton, instead use
|
||||
standard inet_pton API (and emulate it on platforms that do not
|
||||
support it).
|
||||
(GNAT.Sockets.Thin.Inet_Pton, VMS case): Implement in terms of
|
||||
DECC$INET_ADDR, imported in Ada.
|
||||
(GNAT.Sockets.Thin.Inet_Pton, VxWorks and Windows cases): Use C
|
||||
implementation provided by GNAT runtime.
|
||||
(__gnat_inet_pton): C implementation of inet_pton(3) for VxWorks and
|
||||
Windows.
|
||||
|
||||
2009-04-20 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* gnat_ugn.texi: Add documentation for -fno-ivopts.
|
||||
|
||||
@ -506,8 +506,8 @@ package body Einfo is
|
||||
-- Overlays_Constant Flag243
|
||||
-- Is_RACW_Stub_Type Flag244
|
||||
-- Is_Private_Primitive Flag245
|
||||
-- Is_Underlying_Record_View Flag246
|
||||
|
||||
-- (unused) Flag246
|
||||
-- (unused) Flag247
|
||||
|
||||
-----------------------
|
||||
@ -2066,6 +2066,11 @@ package body Einfo is
|
||||
return Flag117 (Implementation_Base_Type (Id));
|
||||
end Is_Unchecked_Union;
|
||||
|
||||
function Is_Underlying_Record_View (Id : E) return B is
|
||||
begin
|
||||
return Flag246 (Id);
|
||||
end Is_Underlying_Record_View;
|
||||
|
||||
function Is_Unsigned_Type (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id));
|
||||
@ -2675,7 +2680,6 @@ package body Einfo is
|
||||
|
||||
function Underlying_Record_View (Id : E) return E is
|
||||
begin
|
||||
pragma Assert (Ekind (Id) = E_Record_Type);
|
||||
return Node24 (Id);
|
||||
end Underlying_Record_View;
|
||||
|
||||
@ -4543,6 +4547,12 @@ package body Einfo is
|
||||
Set_Flag117 (Id, V);
|
||||
end Set_Is_Unchecked_Union;
|
||||
|
||||
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Ekind (Id) = E_Record_Type);
|
||||
Set_Flag246 (Id, V);
|
||||
end Set_Is_Underlying_Record_View;
|
||||
|
||||
procedure Set_Is_Unsigned_Type (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Discrete_Or_Fixed_Point_Type (Id));
|
||||
@ -6973,6 +6983,7 @@ package body Einfo is
|
||||
W ("Is_Trivial_Subprogram", Flag235 (Id));
|
||||
W ("Is_True_Constant", Flag163 (Id));
|
||||
W ("Is_Unchecked_Union", Flag117 (Id));
|
||||
W ("Is_Underlying_Record_View", Flag246 (Id));
|
||||
W ("Is_Unsigned_Type", Flag144 (Id));
|
||||
W ("Is_VMS_Exception", Flag133 (Id));
|
||||
W ("Is_Valued_Procedure", Flag127 (Id));
|
||||
|
||||
@ -2633,6 +2633,13 @@ package Einfo is
|
||||
-- Present in all entities. Set only in record types to which the
|
||||
-- pragma Unchecked_Union has been validly applied.
|
||||
|
||||
-- Is_Underlying_Record_View (Flag246) [base type only]
|
||||
-- Present in all entities. Set only in record types that represent the
|
||||
-- underlying record view. This view is built for derivations of types
|
||||
-- with unknown discriminants; it is a record with the same structure
|
||||
-- than its corresponding record type, and whose parent is the full view
|
||||
-- of the parent in the original type extension.
|
||||
|
||||
-- Is_Unsigned_Type (Flag144)
|
||||
-- Present in all types, but can be set only for discrete and fixed-point
|
||||
-- type and subtype entities. This flag is only valid if the entity is
|
||||
@ -3560,10 +3567,13 @@ package Einfo is
|
||||
|
||||
-- Underlying_Record_View (Node24)
|
||||
-- Present in record types. Set for record types that are extensions of
|
||||
-- types with unknown discriminants. Such types do not have a completion,
|
||||
-- but they cannot be used without having some discriminated view at
|
||||
-- hand. This view is a record type with the same structure, whose parent
|
||||
-- type is the full view of the parent in the original type extension.
|
||||
-- types with unknown discriminants, and also set for internally built
|
||||
-- underlying record views to reference its original record type. Record
|
||||
-- types that are extensions of types with unknown discriminants do not
|
||||
-- have a completion, but they cannot be used without having some
|
||||
-- discriminated view at hand. This view is a record type with the same
|
||||
-- structure, whose parent type is the full view of the parent in the
|
||||
-- original type extension.
|
||||
|
||||
-- Underlying_Type (synthesized)
|
||||
-- Applies to all entities. This is the identity function except in the
|
||||
@ -5889,6 +5899,7 @@ package Einfo is
|
||||
function Is_Trivial_Subprogram (Id : E) return B;
|
||||
function Is_True_Constant (Id : E) return B;
|
||||
function Is_Unchecked_Union (Id : E) return B;
|
||||
function Is_Underlying_Record_View (Id : E) return B;
|
||||
function Is_Unsigned_Type (Id : E) return B;
|
||||
function Is_VMS_Exception (Id : E) return B;
|
||||
function Is_Valued_Procedure (Id : E) return B;
|
||||
@ -6441,6 +6452,7 @@ package Einfo is
|
||||
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
|
||||
procedure Set_Is_True_Constant (Id : E; V : B := True);
|
||||
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
|
||||
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
|
||||
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
|
||||
procedure Set_Is_VMS_Exception (Id : E; V : B := True);
|
||||
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
|
||||
@ -7132,6 +7144,7 @@ package Einfo is
|
||||
pragma Inline (Is_Trivial_Subprogram);
|
||||
pragma Inline (Is_Type);
|
||||
pragma Inline (Is_Unchecked_Union);
|
||||
pragma Inline (Is_Underlying_Record_View);
|
||||
pragma Inline (Is_Unsigned_Type);
|
||||
pragma Inline (Is_VMS_Exception);
|
||||
pragma Inline (Is_Valued_Procedure);
|
||||
@ -7520,6 +7533,7 @@ package Einfo is
|
||||
pragma Inline (Set_Is_Trivial_Subprogram);
|
||||
pragma Inline (Set_Is_True_Constant);
|
||||
pragma Inline (Set_Is_Unchecked_Union);
|
||||
pragma Inline (Set_Is_Underlying_Record_View);
|
||||
pragma Inline (Set_Is_Unsigned_Type);
|
||||
pragma Inline (Set_Is_VMS_Exception);
|
||||
pragma Inline (Set_Is_Valued_Procedure);
|
||||
|
||||
@ -1869,7 +1869,9 @@ package body Exp_Aggr is
|
||||
|
||||
Parent_Typ := Etype (Current_Typ);
|
||||
while Current_Typ /= Parent_Typ loop
|
||||
if Has_Discriminants (Parent_Typ) then
|
||||
if Has_Discriminants (Parent_Typ)
|
||||
and then not Has_Unknown_Discriminants (Parent_Typ)
|
||||
then
|
||||
Parent_Disc := First_Discriminant (Parent_Typ);
|
||||
|
||||
-- We either get the association from the subtype indication
|
||||
|
||||
@ -3908,8 +3908,11 @@ package body Exp_Attr is
|
||||
-- For X'Size applied to an object of a class-wide type, transform
|
||||
-- X'Size into a call to the primitive operation _Size applied to X.
|
||||
|
||||
elsif Is_Class_Wide_Type (Ptyp) then
|
||||
|
||||
elsif Is_Class_Wide_Type (Ptyp)
|
||||
or else (Id = Attribute_Size
|
||||
and then Is_Tagged_Type (Ptyp)
|
||||
and then Has_Unknown_Discriminants (Ptyp))
|
||||
then
|
||||
-- No need to do anything else compiling under restriction
|
||||
-- No_Dispatching_Calls. During the semantic analysis we
|
||||
-- already notified such violation.
|
||||
@ -3936,7 +3939,7 @@ package body Exp_Attr is
|
||||
|
||||
Rewrite (N, New_Node);
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
return;
|
||||
return;
|
||||
|
||||
-- Case of known RM_Size of a type
|
||||
|
||||
|
||||
@ -170,16 +170,18 @@ package body Exp_Disp is
|
||||
and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
|
||||
and then not Is_Private_Type (Defining_Entity (D))
|
||||
then
|
||||
-- We do not generate dispatch tables for the internal type
|
||||
-- We do not generate dispatch tables for the internal types
|
||||
-- created for a type extension with unknown discriminants
|
||||
-- The needed information is shared with the source type,
|
||||
-- See Expand_N_Record_Extension.
|
||||
|
||||
if not Comes_From_Source (Defining_Entity (D))
|
||||
and then
|
||||
if Is_Underlying_Record_View (Defining_Entity (D))
|
||||
or else
|
||||
(not Comes_From_Source (Defining_Entity (D))
|
||||
and then
|
||||
Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
|
||||
and then
|
||||
not Comes_From_Source (First_Subtype (Defining_Entity (D)))
|
||||
and then
|
||||
not Comes_From_Source (First_Subtype (Defining_Entity (D))))
|
||||
then
|
||||
null;
|
||||
|
||||
|
||||
@ -1278,6 +1278,7 @@ package body GNAT.Sockets is
|
||||
use Interfaces.C.Strings;
|
||||
|
||||
Img : aliased char_array := To_C (Image);
|
||||
Cp : constant chars_ptr := To_Chars_Ptr (Img'Unchecked_Access);
|
||||
Addr : aliased C.int;
|
||||
Res : C.int;
|
||||
Result : Inet_Addr_Type;
|
||||
@ -1290,9 +1291,12 @@ package body GNAT.Sockets is
|
||||
Raise_Socket_Error (SOSC.EINVAL);
|
||||
end if;
|
||||
|
||||
Res := Inet_Aton (To_Chars_Ptr (Img'Unchecked_Access), Addr'Address);
|
||||
Res := Inet_Pton (SOSC.AF_INET, Cp, Addr'Address);
|
||||
|
||||
if Res = 0 then
|
||||
if Res < 0 then
|
||||
Raise_Socket_Error (Socket_Errno);
|
||||
|
||||
elsif Res = 0 then
|
||||
Raise_Socket_Error (SOSC.EINVAL);
|
||||
end if;
|
||||
|
||||
|
||||
@ -115,8 +115,9 @@ package GNAT.Sockets.Thin is
|
||||
Optval : System.Address;
|
||||
Optlen : not null access C.int) return C.int;
|
||||
|
||||
function Inet_Aton
|
||||
(Cp : C.Strings.chars_ptr;
|
||||
function Inet_Pton
|
||||
(Af : C.int;
|
||||
Cp : C.Strings.chars_ptr;
|
||||
Inp : System.Address) return C.int;
|
||||
|
||||
function C_Ioctl
|
||||
@ -233,7 +234,7 @@ private
|
||||
pragma Import (Stdcall, C_Getpeername, "getpeername");
|
||||
pragma Import (Stdcall, C_Getsockname, "getsockname");
|
||||
pragma Import (Stdcall, C_Getsockopt, "getsockopt");
|
||||
pragma Import (Stdcall, Inet_Aton, "inet_aton");
|
||||
pragma Import (Stdcall, Inet_Pton, "__gnat_inet_pton");
|
||||
pragma Import (Stdcall, C_Ioctl, "ioctlsocket");
|
||||
pragma Import (Stdcall, C_Listen, "listen");
|
||||
pragma Import (Stdcall, C_Recv, "recv");
|
||||
|
||||
@ -354,15 +354,15 @@ package body GNAT.Sockets.Thin is
|
||||
package body Host_Error_Messages is separate;
|
||||
|
||||
---------------
|
||||
-- Inet_Aton --
|
||||
-- Inet_Pton --
|
||||
---------------
|
||||
|
||||
-- VMS does not support inet_aton(3), so emulate it here in terms of
|
||||
-- inet_addr(3). Note: unlike other C functions, inet_aton reports
|
||||
-- failure with a 0 return, and success with a non-zero return.
|
||||
-- VMS does not support inet_pton(3), so emulate it here in terms of
|
||||
-- inet_addr(3).
|
||||
|
||||
function Inet_Aton
|
||||
(Cp : C.Strings.chars_ptr;
|
||||
function Inet_Pton
|
||||
(Af : C.int;
|
||||
Cp : C.Strings.chars_ptr;
|
||||
Inp : System.Address) return C.int
|
||||
is
|
||||
use C.Strings;
|
||||
@ -373,6 +373,11 @@ package body GNAT.Sockets.Thin is
|
||||
function C_Inet_Addr (Cp : C.Strings.chars_ptr) return C.int;
|
||||
pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR");
|
||||
begin
|
||||
if Af /= SOSC.AF_INET then
|
||||
Set_Socket_Errno (SOSC.EAFNOSUPPORT);
|
||||
return -1;
|
||||
end if;
|
||||
|
||||
if Cp = Null_Ptr or else Inp = Null_Address then
|
||||
return 0;
|
||||
end if;
|
||||
@ -387,13 +392,18 @@ package body GNAT.Sockets.Thin is
|
||||
end if;
|
||||
|
||||
Res := C_Inet_Addr (Cp);
|
||||
|
||||
-- String is not a valid dotted quad
|
||||
|
||||
if Res = -1 then
|
||||
return 0;
|
||||
end if;
|
||||
|
||||
-- Success
|
||||
|
||||
Conv.To_Pointer (Inp).all := Res;
|
||||
return 1;
|
||||
end Inet_Aton;
|
||||
end Inet_Pton;
|
||||
|
||||
----------------
|
||||
-- Initialize --
|
||||
|
||||
@ -118,8 +118,9 @@ package GNAT.Sockets.Thin is
|
||||
Optval : System.Address;
|
||||
Optlen : not null access C.int) return C.int;
|
||||
|
||||
function Inet_Aton
|
||||
(Cp : C.Strings.chars_ptr;
|
||||
function Inet_Pton
|
||||
(Af : C.int;
|
||||
Cp : C.Strings.chars_ptr;
|
||||
Inp : System.Address) return C.int;
|
||||
|
||||
function C_Ioctl
|
||||
|
||||
@ -116,8 +116,9 @@ package GNAT.Sockets.Thin is
|
||||
Optval : System.Address;
|
||||
Optlen : not null access C.int) return C.int;
|
||||
|
||||
function Inet_Aton
|
||||
(Cp : C.Strings.chars_ptr;
|
||||
function Inet_Pton
|
||||
(Af : C.int;
|
||||
Cp : C.Strings.chars_ptr;
|
||||
Inp : System.Address) return C.int;
|
||||
|
||||
function C_Ioctl
|
||||
@ -227,7 +228,7 @@ private
|
||||
pragma Import (C, C_Getpeername, "getpeername");
|
||||
pragma Import (C, C_Getsockname, "getsockname");
|
||||
pragma Import (C, C_Getsockopt, "getsockopt");
|
||||
pragma Import (C, Inet_Aton, "inet_aton");
|
||||
pragma Import (C, Inet_Pton, "__gnat_inet_pton");
|
||||
pragma Import (C, C_Listen, "listen");
|
||||
pragma Import (C, C_Readv, "readv");
|
||||
pragma Import (C, C_Select, "select");
|
||||
|
||||
@ -117,8 +117,9 @@ package GNAT.Sockets.Thin is
|
||||
Optval : System.Address;
|
||||
Optlen : not null access C.int) return C.int;
|
||||
|
||||
function Inet_Aton
|
||||
(Cp : C.Strings.chars_ptr;
|
||||
function Inet_Pton
|
||||
(Af : C.int;
|
||||
Cp : C.Strings.chars_ptr;
|
||||
Inp : System.Address) return C.int;
|
||||
|
||||
function C_Ioctl
|
||||
@ -252,7 +253,7 @@ private
|
||||
pragma Import (C, C_Getpeername, "getpeername");
|
||||
pragma Import (C, C_Getsockname, "getsockname");
|
||||
pragma Import (C, C_Getsockopt, "getsockopt");
|
||||
pragma Import (C, Inet_Aton, "inet_aton");
|
||||
pragma Import (C, Inet_Pton, "inet_pton");
|
||||
pragma Import (C, C_Listen, "listen");
|
||||
pragma Import (C, C_Readv, "readv");
|
||||
pragma Import (C, C_Select, "select");
|
||||
|
||||
@ -2427,6 +2427,16 @@ package body Sem_Aggr is
|
||||
Ancestor_Typ := Etype (Ancestor);
|
||||
Loc := Sloc (Ancestor);
|
||||
|
||||
-- In case of private types with unknown discriminants use the
|
||||
-- underlying record view if it is available
|
||||
|
||||
if Has_Unknown_Discriminants (Ancestor_Typ)
|
||||
and then Present (Full_View (Ancestor_Typ))
|
||||
and then Present (Underlying_Record_View (Full_View (Ancestor_Typ)))
|
||||
then
|
||||
Ancestor_Typ := Underlying_Record_View (Full_View (Ancestor_Typ));
|
||||
end if;
|
||||
|
||||
Ancestor_Is_Subtyp :=
|
||||
Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
|
||||
|
||||
@ -2868,7 +2878,11 @@ package body Sem_Aggr is
|
||||
Positional_Expr := Empty;
|
||||
end if;
|
||||
|
||||
if Has_Discriminants (Typ) then
|
||||
if Has_Unknown_Discriminants (Typ)
|
||||
and then Present (Underlying_Record_View (Typ))
|
||||
then
|
||||
Discrim := First_Discriminant (Underlying_Record_View (Typ));
|
||||
elsif Has_Discriminants (Typ) then
|
||||
Discrim := First_Discriminant (Typ);
|
||||
else
|
||||
Discrim := Empty;
|
||||
@ -2948,7 +2962,10 @@ package body Sem_Aggr is
|
||||
-- this may be a problem. What should be done in this case is
|
||||
-- to reuse itypes as much as possible.
|
||||
|
||||
if Has_Discriminants (Typ) then
|
||||
if Has_Discriminants (Typ)
|
||||
or else (Has_Unknown_Discriminants (Typ)
|
||||
and then Present (Underlying_Record_View (Typ)))
|
||||
then
|
||||
Build_Constrained_Itype : declare
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Indic : Node_Id;
|
||||
@ -2964,10 +2981,23 @@ package body Sem_Aggr is
|
||||
Next (New_Assoc);
|
||||
end loop;
|
||||
|
||||
Indic :=
|
||||
Make_Subtype_Indication (Loc,
|
||||
Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
|
||||
Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
|
||||
if Has_Unknown_Discriminants (Typ)
|
||||
and then Present (Underlying_Record_View (Typ))
|
||||
then
|
||||
Indic :=
|
||||
Make_Subtype_Indication (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
|
||||
Constraint =>
|
||||
Make_Index_Or_Discriminant_Constraint (Loc, C));
|
||||
else
|
||||
Indic :=
|
||||
Make_Subtype_Indication (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of (Base_Type (Typ), Loc),
|
||||
Constraint =>
|
||||
Make_Index_Or_Discriminant_Constraint (Loc, C));
|
||||
end if;
|
||||
|
||||
Def_Id := Create_Itype (Ekind (Typ), N);
|
||||
|
||||
@ -3044,7 +3074,7 @@ package body Sem_Aggr is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Parent_Typ := Base_Type (Typ);
|
||||
Parent_Typ := Base_Type (Typ);
|
||||
while Parent_Typ /= Root_Typ loop
|
||||
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
|
||||
Parent_Typ := Etype (Parent_Typ);
|
||||
|
||||
@ -774,7 +774,7 @@ package body Sem_Ch10 is
|
||||
Version_Update (N, Lib_Unit);
|
||||
end if;
|
||||
|
||||
-- If this is a child unit, generate references to the parents.
|
||||
-- If this is a child unit, generate references to the parents
|
||||
|
||||
if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
|
||||
N_Defining_Program_Unit_Name
|
||||
@ -785,8 +785,8 @@ package body Sem_Ch10 is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If it is a child unit, the parent must be elaborated first
|
||||
-- and we update version, since we are dependent on our parent.
|
||||
-- If it is a child unit, the parent must be elaborated first and we
|
||||
-- update version, since we are dependent on our parent.
|
||||
|
||||
if Is_Child_Spec (Unit_Node) then
|
||||
|
||||
|
||||
@ -5523,29 +5523,38 @@ package body Sem_Ch3 is
|
||||
|
||||
begin
|
||||
if Is_Tagged_Type (Parent_Type) then
|
||||
Full_P := Full_View (Parent_Type);
|
||||
|
||||
-- A type extension of a type with unknown discriminants is an
|
||||
-- indefinite type that the back-end cannot handle directly.
|
||||
-- We treat it as a private type, and build a completion that is
|
||||
-- derived from the full view of the parent, and hopefully has
|
||||
-- known discriminants. The implementation of more complex chains
|
||||
-- of derivation with unknown discriminants is left to the more
|
||||
-- enterprising reader.
|
||||
-- known discriminants.
|
||||
|
||||
-- If the full view of the parent type has its underlying record view
|
||||
-- available then use it to generate the underlying record view of
|
||||
-- this Derived_Type (required to handle chains of derivations with
|
||||
-- unknown discriminants).
|
||||
|
||||
-- Minor optimization: We avoid the generation of useless underlying
|
||||
-- record view entities if the private type declaration has unknown
|
||||
-- discriminants but its corresponding full view has no discriminants
|
||||
|
||||
if Has_Unknown_Discriminants (Parent_Type)
|
||||
and then Present (Full_View (Parent_Type))
|
||||
and then Present (Full_P)
|
||||
and then (Has_Discriminants (Full_P)
|
||||
or else Present (Underlying_Record_View (Full_P)))
|
||||
and then not In_Open_Scopes (Par_Scope)
|
||||
and then not Is_Completion
|
||||
and then Expander_Active
|
||||
then
|
||||
declare
|
||||
Full_Der : constant Entity_Id :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('T'));
|
||||
Decl : Node_Id;
|
||||
New_Ext : constant Node_Id :=
|
||||
Copy_Separate_Tree
|
||||
(Record_Extension_Part (Type_Definition (N)));
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
Build_Derived_Record_Type
|
||||
@ -5566,13 +5575,40 @@ package body Sem_Ch3 is
|
||||
New_Copy_Tree
|
||||
(Subtype_Indication (Type_Definition (N))),
|
||||
Record_Extension_Part => New_Ext));
|
||||
|
||||
Set_Has_Private_Declaration (Full_Der);
|
||||
Set_Has_Private_Declaration (Derived_Type);
|
||||
|
||||
-- If the parent type has its underlying record view then we
|
||||
-- force here its use to derive the new underlying record view.
|
||||
|
||||
if Present (Underlying_Record_View (Full_P)) then
|
||||
pragma Assert
|
||||
(Nkind (Subtype_Indication (Type_Definition (Decl)))
|
||||
= N_Identifier);
|
||||
Set_Entity (Subtype_Indication (Type_Definition (Decl)),
|
||||
Underlying_Record_View (Full_P));
|
||||
end if;
|
||||
|
||||
Install_Private_Declarations (Par_Scope);
|
||||
Install_Visible_Declarations (Par_Scope);
|
||||
Insert_After (N, Decl);
|
||||
|
||||
-- Mark the entity as underlying record view before its
|
||||
-- analysis. Done to avoid the generation of its list of
|
||||
-- primitives (which is not really required for this entity)
|
||||
-- and thus avoid supurious errors associated with missing
|
||||
-- overriding of its abstract primitives (because they are
|
||||
-- overriden in the list of primitives of Derived_Type).
|
||||
|
||||
Set_Ekind (Full_Der, E_Record_Type);
|
||||
Set_Is_Underlying_Record_View (Full_Der);
|
||||
|
||||
Analyze (Decl);
|
||||
|
||||
pragma Assert (Has_Discriminants (Full_Der)
|
||||
and then not Has_Unknown_Discriminants (Full_Der));
|
||||
|
||||
Uninstall_Declarations (Par_Scope);
|
||||
|
||||
-- Freeze the underlying record view, to prevent generation
|
||||
@ -5580,7 +5616,12 @@ package body Sem_Ch3 is
|
||||
-- with the real derived type.
|
||||
|
||||
Set_Is_Frozen (Full_Der);
|
||||
Set_Underlying_Record_View (Derived_Type, Full_Der);
|
||||
|
||||
-- Keep fully linked the real entity and its underlying record
|
||||
-- view entity
|
||||
|
||||
Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
|
||||
Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
|
||||
end;
|
||||
|
||||
-- if discriminants are known, build derived record
|
||||
@ -7084,7 +7125,13 @@ package body Sem_Ch3 is
|
||||
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
|
||||
end if;
|
||||
|
||||
Make_Class_Wide_Type (Derived_Type);
|
||||
-- Minor optimization: There is no need to generate the class wide
|
||||
-- entity associated with an underlying record view
|
||||
|
||||
if not Is_Underlying_Record_View (Derived_Type) then
|
||||
Make_Class_Wide_Type (Derived_Type);
|
||||
end if;
|
||||
|
||||
Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
|
||||
|
||||
if Has_Discriminants (Derived_Type)
|
||||
@ -7279,10 +7326,13 @@ package body Sem_Ch3 is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Update the class_wide type, which shares the now-completed
|
||||
-- entity list with its specific type.
|
||||
-- Update the class_wide type, which shares the now-completed entity
|
||||
-- list with its specific type. In case of underlying record views
|
||||
-- we do not generate the corresponding class wide entity.
|
||||
|
||||
if Is_Tagged then
|
||||
if Is_Tagged
|
||||
and then not Is_Underlying_Record_View (Derived_Type)
|
||||
then
|
||||
Set_First_Entity
|
||||
(Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
|
||||
Set_Last_Entity
|
||||
@ -13143,7 +13193,10 @@ package body Sem_Ch3 is
|
||||
Error_Msg_N ("null exclusion can only apply to an access type", N);
|
||||
end if;
|
||||
|
||||
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
|
||||
-- Avoid deriving parent primitives in underlying record views
|
||||
|
||||
Build_Derived_Type (N, Parent_Type, T, Is_Completion,
|
||||
Derive_Subps => not Is_Underlying_Record_View (T));
|
||||
|
||||
-- AI-419: The parent type of an explicitly limited derived type must
|
||||
-- be a limited type or a limited interface.
|
||||
|
||||
@ -584,11 +584,19 @@ package body Sem_Ch6 is
|
||||
end if;
|
||||
|
||||
-- Subtype_indication case; check that the types are the same, and
|
||||
-- statically match if appropriate. A null exclusion may be present
|
||||
-- on the return type, on the function specification, on the object
|
||||
-- declaration or on the subtype itself.
|
||||
-- statically match if appropriate. Handle also record types with
|
||||
-- unknown discriminants for which we have built the underlying
|
||||
-- record view.
|
||||
|
||||
elsif Base_Type (R_Stm_Type) = Base_Type (R_Type)
|
||||
or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))
|
||||
and then Underlying_Record_View (Base_Type (R_Stm_Type))
|
||||
= Base_Type (R_Type))
|
||||
then
|
||||
-- A null exclusion may be present on the return type, on the
|
||||
-- function specification, on the object declaration or on the
|
||||
-- subtype itself.
|
||||
|
||||
elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then
|
||||
if Is_Access_Type (R_Type)
|
||||
and then
|
||||
(Can_Never_Be_Null (R_Type)
|
||||
|
||||
@ -745,6 +745,18 @@ package body Sem_Type is
|
||||
else
|
||||
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).
|
||||
|
||||
if Is_Underlying_Record_View (BT1) then
|
||||
BT1 := Underlying_Record_View (BT1);
|
||||
end if;
|
||||
|
||||
if Is_Underlying_Record_View (BT2) then
|
||||
BT2 := Underlying_Record_View (BT2);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Simplest case: same types are compatible, and types that have the
|
||||
@ -2486,20 +2498,37 @@ package body Sem_Type is
|
||||
-----------------
|
||||
|
||||
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
|
||||
BT1 : Entity_Id;
|
||||
BT2 : Entity_Id;
|
||||
Par : Entity_Id;
|
||||
|
||||
begin
|
||||
if Base_Type (T1) = Base_Type (T2) then
|
||||
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).
|
||||
|
||||
if Is_Underlying_Record_View (BT1) then
|
||||
BT1 := Underlying_Record_View (BT1);
|
||||
end if;
|
||||
|
||||
if Is_Underlying_Record_View (BT2) then
|
||||
BT2 := Underlying_Record_View (BT2);
|
||||
end if;
|
||||
|
||||
if BT1 = BT2 then
|
||||
return True;
|
||||
|
||||
elsif Is_Private_Type (T1)
|
||||
and then Present (Full_View (T1))
|
||||
and then Base_Type (T2) = Base_Type (Full_View (T1))
|
||||
and then BT2 = Base_Type (Full_View (T1))
|
||||
then
|
||||
return True;
|
||||
|
||||
else
|
||||
Par := Etype (T2);
|
||||
Par := Etype (BT2);
|
||||
|
||||
loop
|
||||
-- If there was a error on the type declaration, do not recurse
|
||||
@ -2507,7 +2536,7 @@ package body Sem_Type is
|
||||
if Error_Posted (Par) then
|
||||
return False;
|
||||
|
||||
elsif Base_Type (T1) = Base_Type (Par)
|
||||
elsif BT1 = Base_Type (Par)
|
||||
or else (Is_Private_Type (T1)
|
||||
and then Present (Full_View (T1))
|
||||
and then Base_Type (Par) = Base_Type (Full_View (T1)))
|
||||
@ -2516,7 +2545,7 @@ package body Sem_Type is
|
||||
|
||||
elsif Is_Private_Type (Par)
|
||||
and then Present (Full_View (Par))
|
||||
and then Full_View (Par) = Base_Type (T1)
|
||||
and then Full_View (Par) = BT1
|
||||
then
|
||||
return True;
|
||||
|
||||
|
||||
@ -62,8 +62,11 @@ extern void __gnat_insert_socket_in_set (fd_set *, int);
|
||||
extern int __gnat_is_socket_in_set (fd_set *, int);
|
||||
extern fd_set *__gnat_new_socket_set (fd_set *);
|
||||
extern void __gnat_remove_socket_from_set (fd_set *, int);
|
||||
extern void __gnat_reset_socket_set (fd_set *set);
|
||||
extern void __gnat_reset_socket_set (fd_set *);
|
||||
extern int __gnat_get_h_errno (void);
|
||||
#if defined (__vxworks) || defined (_WIN32)
|
||||
extern int __gnat_inet_pton (int, const char *, void *);
|
||||
#endif
|
||||
|
||||
/* Disable the sending of SIGPIPE for writes on a broken stream */
|
||||
|
||||
@ -397,6 +400,46 @@ __gnat_get_h_errno (void) {
|
||||
#endif
|
||||
}
|
||||
|
||||
#if defined (__vxworks) || defined (_WIN32)
|
||||
int
|
||||
__gnat_inet_pton (int af, const char *src, void *dst) {
|
||||
switch (af) {
|
||||
#if defined (_WIN32) && defined (AF_INET6)
|
||||
case AF_INET6:
|
||||
#endif
|
||||
case AF_INET:
|
||||
break;
|
||||
default:
|
||||
errno = EAFNOSUPPORT;
|
||||
return -1;
|
||||
}
|
||||
|
||||
#ifdef __vxworks
|
||||
return (inet_aton (src, dst) == OK);
|
||||
#else
|
||||
struct sockaddr_storage ss;
|
||||
int sslen = sizeof ss;
|
||||
int rc;
|
||||
|
||||
ss.ss_family = af;
|
||||
rc = WSAStringToAddress (src, af, NULL, (struct sockaddr *)&ss, &sslen);
|
||||
if (rc > 0) {
|
||||
switch (af) {
|
||||
case AF_INET:
|
||||
*(struct in_addr *)dst = ((struct sockaddr_in *)&ss)->sin_addr;
|
||||
break;
|
||||
#ifdef AF_INET6
|
||||
case AF_INET6:
|
||||
*(struct in6_addr *)dst = ((struct sockaddr_in6 *)&ss)->sin6_addr;
|
||||
break;
|
||||
#endif
|
||||
}
|
||||
}
|
||||
return rc;
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
|
||||
#else
|
||||
#warning Sockets are not supported on this platform
|
||||
#endif /* defined(HAVE_SOCKETS) */
|
||||
|
||||
@ -961,12 +961,16 @@ package body Sprint is
|
||||
if Present (Expressions (Node)) then
|
||||
Sprint_Comma_List (Expressions (Node));
|
||||
|
||||
if Present (Component_Associations (Node)) then
|
||||
if Present (Component_Associations (Node))
|
||||
and then not Is_Empty_List (Component_Associations (Node))
|
||||
then
|
||||
Write_Str (", ");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if Present (Component_Associations (Node)) then
|
||||
if Present (Component_Associations (Node))
|
||||
and then not Is_Empty_List (Component_Associations (Node))
|
||||
then
|
||||
Indent_Begin;
|
||||
|
||||
declare
|
||||
|
||||
Loading…
Reference in New Issue
Block a user