From a530b8bb19dfadc48d8848259a8f91580ef0c9b3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 8 Jul 2013 09:50:46 +0200 Subject: [multiple changes] 2013-07-08 Ed Schonberg * sem_ch8.adb (Attribute_Renaming): Treat 'Img as an attribute that can be renamed as a function. 2013-07-08 Thomas Quinot * g-socket.ads: Document target dependency: FIONBIO may or may not be inherited from listening socket by accepted socket. 2013-07-08 Hristian Kirtchev * exp_ch4.adb (Apply_Accessibility_Check): Do not deallocate the object on targets that can't deallocate. From-SVN: r200758 --- gcc/ada/ChangeLog | 15 ++++++++ gcc/ada/exp_ch4.adb | 101 ++++++++++++++++++++++++++++++--------------------- gcc/ada/g-socket.ads | 3 +- gcc/ada/sem_ch8.adb | 24 +++++++++--- 4 files changed, 95 insertions(+), 48 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4924539..9f72a45 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2013-07-08 Ed Schonberg + + * sem_ch8.adb (Attribute_Renaming): Treat 'Img as an attribute + that can be renamed as a function. + +2013-07-08 Thomas Quinot + + * g-socket.ads: Document target dependency: FIONBIO may or may not + be inherited from listening socket by accepted socket. + +2013-07-08 Hristian Kirtchev + + * exp_ch4.adb (Apply_Accessibility_Check): Do not deallocate the object + on targets that can't deallocate. + 2013-07-08 Hristian Kirtchev * exp_ch3.adb (Freeze_Type): Generate a diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9b0fc02..f9c6fd8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index c543707..06add2c 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3ceba77..ef9da82 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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)); -- cgit v1.1