From 442049cc40ee654b6b24371b05d7ea79e2e0657c Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 20 Apr 2009 10:18:48 +0000 Subject: [PATCH] 2009-04-20 Javier Miranda * 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 * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@146391 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 52 ++++++++++++++++++++++++++++++ gcc/ada/einfo.adb | 15 +++++++-- gcc/ada/einfo.ads | 22 ++++++++++--- gcc/ada/exp_aggr.adb | 4 ++- gcc/ada/exp_attr.adb | 9 ++++-- gcc/ada/exp_disp.adb | 12 ++++--- gcc/ada/g-socket.adb | 8 +++-- gcc/ada/g-socthi-mingw.ads | 7 ++-- gcc/ada/g-socthi-vms.adb | 24 ++++++++++---- gcc/ada/g-socthi-vms.ads | 5 +-- gcc/ada/g-socthi-vxworks.ads | 7 ++-- gcc/ada/g-socthi.ads | 7 ++-- gcc/ada/sem_aggr.adb | 44 +++++++++++++++++++++---- gcc/ada/sem_ch10.adb | 6 ++-- gcc/ada/sem_ch3.adb | 77 +++++++++++++++++++++++++++++++++++++------- gcc/ada/sem_ch6.adb | 16 ++++++--- gcc/ada/sem_type.adb | 39 +++++++++++++++++++--- gcc/ada/socket.c | 45 +++++++++++++++++++++++++- gcc/ada/sprint.adb | 8 +++-- 19 files changed, 338 insertions(+), 69 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d2370239a88..80163b61035 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,55 @@ +2009-04-20 Javier Miranda + + * 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 + + * 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 * gnat_ugn.texi: Add documentation for -fno-ivopts. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 92d9ce26b8f..0146c649699 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 91883e72a89..87bddb9a7f2 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9200165b844..0ffbb453ade 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d1d6ee9862c..5772d58487e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 54a823a848a..85a51f3e633 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 962a8fbae60..cc31d142c57 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -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; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 5588dd00387..9c3ab0c0145 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -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"); diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index d065f998073..9ca32f3c4f5 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -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 -- diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index 1abcbb3385d..1a6e5af99ae 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -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 diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 10c3754f81e..30c2b5057b0 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -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"); diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index e54d59c6a57..720efcdee95 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -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"); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 402b7384c9a..e29bca991c7 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 0a32539774f..cd713c84f77 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d53cb88cbc6..b72fb2f0669 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 17103e1e3b5..2670c3d2531 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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) diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 4e03642b2c6..e5f790011c1 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -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; diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c index 33a06397467..5ddaa39d6a2 100644 --- a/gcc/ada/socket.c +++ b/gcc/ada/socket.c @@ -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) */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 35ecce93fc9..3ae79182c8c 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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 -- 2.11.0