end;
end if;
- -- Processing for possible Implicit_Packing later
+ -- Gather data for possible Implicit_Packing later
- if Implicit_Packing then
- if not Is_Scalar_Type (Etype (Comp)) then
- All_Scalar_Components := False;
- else
- Scalar_Component_Total_RM_Size :=
- Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
- Scalar_Component_Total_Esize :=
- Scalar_Component_Total_Esize + Esize (Etype (Comp));
- end if;
+ if not Is_Scalar_Type (Etype (Comp)) then
+ All_Scalar_Components := False;
+ else
+ Scalar_Component_Total_RM_Size :=
+ Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
+ Scalar_Component_Total_Esize :=
+ Scalar_Component_Total_Esize + Esize (Etype (Comp));
end if;
-- If the component is an Itype with Delayed_Freeze and is either
end;
end if;
- -- Apply implicit packing if all conditions are met
+ -- See if Implicit_Packing would work
- if Implicit_Packing
+ if not Is_Packed (Rec)
+ and then not Placed_Component
and then Has_Size_Clause (Rec)
and then All_Scalar_Components
and then not Has_Discriminants (Rec)
and then Esize (Rec) < Scalar_Component_Total_Esize
and then Esize (Rec) >= Scalar_Component_Total_RM_Size
then
- Set_Is_Packed (Rec);
+ -- If implicit packing enabled, do it
+
+ if Implicit_Packing then
+ Set_Is_Packed (Rec);
+
+ -- Otherwise flag the size clause
+
+ else
+ declare
+ Sz : constant Node_Id := Size_Clause (Rec);
+ begin
+ Error_Msg_NE
+ ("size given for& too small", Sz, Rec);
+ Error_Msg_N
+ ("\use explicit pragma Pack "
+ & "or use pragma Implicit_Packing", Sz);
+ end;
+ end if;
end if;
end Freeze_Record_Type;
package body GNAT.Sockets.Thin is
+ type VMS_Msghdr is new Msghdr;
+ pragma Pack (VMS_Msghdr);
+ -- On VMS (unlike other platforms), struct msghdr is packed, so a specific
+ -- derived type is required.
+
Non_Blocking_Sockets : aliased Fd_Set;
-- When this package is initialized with Process_Blocking_IO set to True,
-- sockets are set in non-blocking mode to avoid blocking the whole process
is
Res : C.int;
+ GNAT_Msg : Msghdr;
+ for GNAT_Msg'Address use Msg;
+ pragma Import (Ada, GNAT_Msg);
+
+ VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
begin
loop
- Res := Syscall_Recvmsg (S, Msg, Flags);
+ Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
+ GNAT_Msg := Msghdr (VMS_Msg);
return ssize_t (Res);
end C_Recvmsg;
is
Res : C.int;
+ GNAT_Msg : Msghdr;
+ for GNAT_Msg'Address use Msg;
+ pragma Import (Ada, GNAT_Msg);
+
+ VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
+
begin
loop
- Res := Syscall_Sendmsg (S, Msg, Flags);
+ Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
+ GNAT_Msg := Msghdr (VMS_Msg);
return ssize_t (Res);
end C_Sendmsg;
end if;
end if;
- -- Special processing for renaming function return object
+ -- Special processing for renaming function return object. Some errors
+ -- and warnings are produced only for calls that come from source.
- if Nkind (Nam) = N_Function_Call
- and then Comes_From_Source (Nam)
- then
+ if Nkind (Nam) = N_Function_Call then
case Ada_Version is
-- Usage is illegal in Ada 83
when Ada_83 =>
- Error_Msg_N
- ("(Ada 83) cannot rename function return object", Nam);
+ if Comes_From_Source (Nam) then
+ Error_Msg_N
+ ("(Ada 83) cannot rename function return object", Nam);
+ end if;
-- In Ada 95, warn for odd case of renaming parameterless function
- -- call if this is not a limited type (where this is useful)
+ -- call if this is not a limited type (where this is useful).
when others =>
if Warn_On_Object_Renames_Function
and then No (Parameter_Associations (Nam))
and then not Is_Limited_Type (Etype (Nam))
+ and then Comes_From_Source (Nam)
then
Error_Msg_N
- ("?renaming function result object is suspicious",
- Nam);
+ ("?renaming function result object is suspicious", Nam);
Error_Msg_NE
- ("\?function & will be called only once",
- Nam, Entity (Name (Nam)));
+ ("\?function & will be called only once", Nam,
+ Entity (Name (Nam)));
Error_Msg_N
("\?suggest using an initialized constant object instead",
Nam);
end if;
- -- If the function call returns an unconstrained type, we
- -- must build a constrained subtype for the new entity, in
- -- a way similar to what is done for an object declaration
- -- with an unconstrained nominal type.
+ -- If the function call returns an unconstrained type, we must
+ -- build a constrained subtype for the new entity, in a way
+ -- similar to what is done for an object declaration with an
+ -- unconstrained nominal type.
if Is_Composite_Type (Etype (Nam))
and then not Is_Constrained (Etype (Nam))
then
Error_Msg_NE ("invalid use of incomplete type&", Id, T2);
return;
+
elsif Ekind (Etype (T)) = E_Incomplete_Type then
Error_Msg_NE ("invalid use of incomplete type&", Id, T);
return;
and then Nkind (Nam) in N_Has_Entity
then
declare
- Nam_Decl : Node_Id;
- Nam_Ent : Entity_Id;
+ Nam_Decl : Node_Id;
+ Nam_Ent : Entity_Id;
begin
if Nkind (Nam) = N_Attribute_Reference then
Nam_Ent := Entity (Nam);
end if;
- Nam_Decl := Parent (Nam_Ent);
+ Nam_Decl := Parent (Nam_Ent);
if Has_Null_Exclusion (N)
and then not Has_Null_Exclusion (Nam_Decl)
-- have a null exclusion or a null-excluding subtype.
if Is_Formal_Object (Nam_Ent)
- and then In_Generic_Scope (Id)
+ and then In_Generic_Scope (Id)
then
if not Can_Never_Be_Null (Etype (Nam_Ent)) then
Error_Msg_N
-- of the renamed actual in the instance will raise
-- constraint_error.
- elsif Nkind (Parent (Nam_Ent)) = N_Object_Declaration
+ elsif Nkind (Nam_Decl) = N_Object_Declaration
and then In_Instance
and then Present
- (Corresponding_Generic_Association (Parent (Nam_Ent)))
- and then Nkind (Expression (Parent (Nam_Ent)))
+ (Corresponding_Generic_Association (Nam_Decl))
+ and then Nkind (Expression (Nam_Decl))
= N_Raise_Constraint_Error
then
Error_Msg_N
-- must not be null-excluding.
elsif No (Access_Definition (N))
- and then Can_Never_Be_Null (T)
+ and then Can_Never_Be_Null (T)
then
Error_Msg_NE
("`NOT NULL` not allowed (& already excludes null)",
then
Error_Msg_N
("illegal renaming of discriminant-dependent component", Nam);
- else
- null;
end if;
-- A static function call may have been folded into a literal
return;
end if;
- -- Apply Text_IO kludge here, since we may be renaming one of the
- -- children of Text_IO.
+ -- Apply Text_IO kludge here since we may be renaming a child of Text_IO
Text_IO_Kludge (Name (N));
end if;
if Etype (Old_P) = Any_Type then
- Error_Msg_N
- ("expect package name in renaming", Name (N));
+ Error_Msg_N ("expect package name in renaming", Name (N));
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
Inherit_Renamed_Profile (New_S, Old_S);
- -- The prefix can be an arbitrary expression that yields a task
- -- type, so it must be resolved.
+ -- The prefix can be an arbitrary expression that yields a task type,
+ -- so it must be resolved.
Resolve (Prefix (Nam), Scope (Old_S));
end if;
projects / gcc.git / commitdiff