Skip to content

R
riscv-gcc-1
Commit 426d2717 by Arnaud Charlet
Options

[multiple changes] 

2009-05-06  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Freeze_Record_Type): Improve error msg for bad size
	clause.

2009-05-06  Thomas Quinot  <quinot@adacore.com>

	* g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate
	packed type, since on OpenVMS, struct msghdr is packed.

2009-05-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Object_Renaming): If the object is a function
	call returning an unconstrained composite value, create the proper
	subtype for it, as is done for object dclarations with unconstrained
	nominal subtypes. Perform this transformation regarless of whether
	call comes from source.

From-SVN: r147159
parent 8dc10d38
Showing with 96 additions and 46 deletions
gcc/ada/ChangeLog
2009-05-06 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Record_Type): Improve error msg for bad size
clause.
2009-05-06 Thomas Quinot <quinot@adacore.com>
* g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate
packed type, since on OpenVMS, struct msghdr is packed.
2009-05-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Analyze_Object_Renaming): If the object is a function
call returning an unconstrained composite value, create the proper
subtype for it, as is done for object dclarations with unconstrained
nominal subtypes. Perform this transformation regarless of whether
call comes from source.
2009-05-06 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Record_Type): Implement Implicit_Packing for
records
......
gcc/ada/freeze.adb
......@@ -1864,17 +1864,15 @@ package body Freeze is
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
......@@ -2186,16 +2184,34 @@ package body Freeze is
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;
......
gcc/ada/g-socthi-vms.adb
......@@ -40,6 +40,11 @@ with Interfaces.C; use Interfaces.C;
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
......@@ -300,15 +305,21 @@ package body GNAT.Sockets.Thin is
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;
......@@ -324,15 +335,22 @@ package body GNAT.Sockets.Thin is
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;
......
gcc/ada/sem_ch8.adb
......@@ -866,42 +866,43 @@ package body Sem_Ch8 is
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))
......@@ -945,6 +946,7 @@ package body Sem_Ch8 is
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;
......@@ -962,8 +964,8 @@ package body Sem_Ch8 is
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
......@@ -972,7 +974,7 @@ package body Sem_Ch8 is
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)
......@@ -985,7 +987,7 @@ package body Sem_Ch8 is
-- 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
......@@ -1012,11 +1014,11 @@ package body Sem_Ch8 is
-- 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
......@@ -1027,7 +1029,7 @@ package body Sem_Ch8 is
-- 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)",
......@@ -1067,8 +1069,6 @@ package body Sem_Ch8 is
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
......@@ -1143,8 +1143,7 @@ package body Sem_Ch8 is
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));
......@@ -1162,8 +1161,7 @@ package body Sem_Ch8 is
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
......@@ -1400,8 +1398,8 @@ package body Sem_Ch8 is
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment