+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.
-- Overlays_Constant Flag243
-- Is_RACW_Stub_Type Flag244
-- Is_Private_Primitive Flag245
+ -- Is_Underlying_Record_View Flag246
- -- (unused) Flag246
-- (unused) Flag247
-----------------------
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));
function Underlying_Record_View (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Record_Type);
return Node24 (Id);
end Underlying_Record_View;
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));
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));
-- 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
-- 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
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;
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);
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);
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);
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
-- 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.
Rewrite (N, New_Node);
Analyze_And_Resolve (N, Typ);
- return;
+ return;
-- Case of known RM_Size of a type
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;
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;
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;
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
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");
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;
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;
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 --
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
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
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");
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
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");
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));
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;
-- 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;
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);
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);
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
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
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
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
-- 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
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)
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
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.
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)
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
-----------------
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
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)))
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;
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
\f
/* Disable the sending of SIGPIPE for writes on a broken stream */
#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) */
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
OSDN Git Service
