Commit a530b8bb by Arnaud Charlet

[multiple changes]

2013-07-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Attribute_Renaming): Treat 'Img as an attribute
	that can be renamed as a function.

2013-07-08  Thomas Quinot  <quinot@adacore.com>

	* g-socket.ads: Document target dependency: FIONBIO may or may not
	be inherited from listening socket by accepted socket.

2013-07-08  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Apply_Accessibility_Check): Do not deallocate the object
	on targets that can't deallocate.

From-SVN: r200758
parent a35017dc
2013-07-08 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Attribute_Renaming): Treat 'Img as an attribute
that can be renamed as a function.
2013-07-08 Thomas Quinot <quinot@adacore.com>
* g-socket.ads: Document target dependency: FIONBIO may or may not
be inherited from listening socket by accepted socket.
2013-07-08 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Apply_Accessibility_Check): Do not deallocate the object
on targets that can't deallocate.
2013-07-08 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Freeze_Type): Generate a
......
......@@ -751,47 +751,66 @@ package body Exp_Ch4 is
Stmts := New_List;
-- Create an explicit free statement to clean up the allocated
-- object in case the accessibility check fails. Generate:
-- Free (Obj_Ref);
Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
Set_Storage_Pool (Free_Stmt, Pool_Id);
Append_To (Stmts, Free_Stmt);
-- Finalize the object (if applicable), but wrap the call inside
-- a block to ensure that the object would still be deallocated in
-- case the finalization fails. Generate:
-- begin
-- [Deep_]Finalize (Obj_Ref.all);
-- exception
-- when others =>
-- Free (Obj_Ref);
-- raise;
-- end;
if Needs_Finalization (DesigT) then
Prepend_To (Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Copy (Obj_Ref)),
Typ => DesigT)),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
New_Copy_Tree (Free_Stmt),
Make_Raise_Statement (Loc)))))));
-- If the target does not support allocation/deallocation, simply
-- finalize the object (if applicable). Generate:
-- [Deep_]Finalize (Obj_Ref.all);
if Restriction_Active (No_Implicit_Heap_Allocations) then
if Needs_Finalization (DesigT) then
Append_To (Stmts,
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT));
end if;
-- Finalize (if applicable) and deallocate the object in case the
-- accessibility check fails.
else
-- Create an explicit free statement to clean up the allocated
-- object in case the accessibility check fails. Generate:
-- Free (Obj_Ref);
Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
Set_Storage_Pool (Free_Stmt, Pool_Id);
Append_To (Stmts, Free_Stmt);
-- Finalize the object (if applicable), but wrap the call
-- inside a block to ensure that the object would still be
-- deallocated in case the finalization fails. Generate:
-- begin
-- [Deep_]Finalize (Obj_Ref.all);
-- exception
-- when others =>
-- Free (Obj_Ref);
-- raise;
-- end;
if Needs_Finalization (DesigT) then
Prepend_To (Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Copy (Obj_Ref)),
Typ => DesigT)),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
New_Copy_Tree (Free_Stmt),
Make_Raise_Statement (Loc)))))));
end if;
end if;
-- Signal the accessibility failure through a Program_Error
......
......@@ -816,7 +816,8 @@ package GNAT.Sockets is
-- connections, creates a new connected socket with mostly the same
-- properties as Server, and allocates a new socket. The returned Address
-- is filled in with the address of the connection. Raises Socket_Error on
-- error.
-- error. Note: if Server is a non-blocking socket, whether or not this
-- aspect is inherited by Socket is platform-dependent.
procedure Accept_Socket
(Server : Socket_Type;
......
......@@ -3318,12 +3318,14 @@ package body Sem_Ch8 is
-- This procedure is called in the context of subprogram renaming, and
-- thus the attribute must be one that is a subprogram. All of those
-- have at least one formal parameter, with the singular exception of
-- AST_Entry (which is a real oddity, it is odd that this can be renamed
-- at all!)
-- have at least one formal parameter, with the exceptions of AST_Entry
-- (which is a real oddity, it is odd that this can be renamed at all!)
-- and the GNAT attribute 'Img, which GNAT treats as renameable.
if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
if Aname /= Name_AST_Entry then
if Aname /= Name_AST_Entry
and then Aname /= Name_Img
then
Error_Msg_N
("subprogram renaming an attribute must have formals", N);
return;
......@@ -3493,10 +3495,20 @@ package body Sem_Ch8 is
and then Etype (Nam) /= RTE (RE_AST_Handler)
then
declare
P : constant Entity_Id := Prefix (Nam);
P : constant Node_Id := Prefix (Nam);
begin
Find_Type (P);
-- The prefix of 'Img is an object that is evaluated for
-- each call of the function that renames it.
if Aname = Name_Img then
Preanalyze_And_Resolve (P);
-- For all other attribute renamings, the prefix is a subtype.
else
Find_Type (P);
end if;
if Is_Tagged_Type (Etype (P)) then
Ensure_Freeze_Node (Etype (P));
......
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