diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
| -rw-r--r-- | gcc/ada/a-coinho-shared.adb | 94 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/s-os_lib.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 91 |
6 files changed, 178 insertions, 63 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9212252..5d5be94 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2017-01-13 Javier Miranda <miranda@adacore.com> + + * sem_ch6.adb (Freeze_Expr_Types): New subprogram. + (Analyze_Subprogram_Body_Helper): At the occurrence of an + expression function declaration that is a completion, its + expression causes freezing (AI12-0103). + +2017-01-13 Vadim Godunko <godunko@adacore.com> + + * a-coinho-shared.adb: Fix memory leaks in Constant_Reference and + Reference functions of Ada.Containers.Indefinite_Holders. + +2017-01-13 Bob Duff <duff@adacore.com> + + * s-os_lib.ads: Minor comment fixes. + +2017-01-13 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Default_Initialize_Object): Do not default + initialize an object when it is of a task type and restriction + No_Tasking is in effect because the initialization is obsolete. + * exp_ch9.adb (Build_Master_Entity): Do not generate a master when + restriction No_Tasking is in effect. + (Build_Master_Renaming): Do not rename a master when restriction + No_Tasking is in effect. + 2017-01-13 Ed Schonberg <schonberg@adacore.com> * sem_aggr.adb (Resolve_Array_Aggregate): The code that verifies diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb index 81732b9..3373dbd 100644 --- a/gcc/ada/a-coinho-shared.adb +++ b/gcc/ada/a-coinho-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2013-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2013-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,10 @@ package body Ada.Containers.Indefinite_Holders is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + procedure Detach (Container : Holder); + -- Detach data from shared copy if necessary. This is necessary to prepare + -- container to be modified. + --------- -- "=" -- --------- @@ -142,21 +146,10 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; - - elsif Container.Busy = 0 - and then not System.Atomic_Counters.Is_One - (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - Container'Unrestricted_Access.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Container.Reference.Element.all)); end if; + Detach (Container); + declare Ref : constant Constant_Reference_Type := (Element => Container.Reference.Element.all'Access, @@ -197,6 +190,34 @@ package body Ada.Containers.Indefinite_Holders is end if; end Copy; + ------------ + -- Detach -- + ------------ + + procedure Detach (Container : Holder) is + begin + if Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + declare + Old : constant Shared_Holder_Access := Container.Reference; + + begin + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + Unreference (Old); + end; + end if; + end Detach; + ------------- -- Element -- ------------- @@ -281,21 +302,10 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; - - elsif Container.Busy = 0 - and then - not System.Atomic_Counters.Is_One (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - Container'Unrestricted_Access.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Container.Reference.Element.all)); end if; + Detach (Container); + B := B + 1; begin @@ -359,21 +369,10 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; - - elsif Container.Busy = 0 - and then - not System.Atomic_Counters.Is_One (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Container.Reference.Element.all)); end if; + Detach (Container); + declare Ref : constant Reference_Type := (Element => Container.Reference.Element.all'Access, @@ -477,21 +476,10 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Reference = null then raise Constraint_Error with "container is empty"; - - elsif Container.Busy = 0 - and then - not System.Atomic_Counters.Is_One (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - Container'Unrestricted_Access.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Container.Reference.Element.all)); end if; + Detach (Container); + B := B + 1; begin diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5084714a..219262d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5654,6 +5654,15 @@ package body Exp_Ch3 is if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then return; + + -- Nothing to do if the object being initializes is of a task type + -- and restriction No_Tasking is in effect because this is a direct + -- violation of the restriction. + + elsif Is_Task_Type (Base_Typ) + and then Restriction_Active (No_Tasking) + then + return; end if; -- The expansion performed by this routine is as follows: diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 7cae0e5..4a98f19 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3349,10 +3349,14 @@ package body Exp_Ch9 is Find_Enclosing_Context (Par, Context, Context_Id, Decls); end if; - -- Do not create a master if one already exists or there is no task - -- hierarchy. + -- Nothing to do if the context already has a master - if Has_Master_Entity (Context_Id) + if Has_Master_Entity (Context_Id) then + return; + + -- Nothing to do if tasks or tasking hierarchies are prohibited + + elsif Restriction_Active (No_Tasking) or else Restriction_Active (No_Task_Hierarchy) then return; @@ -3425,9 +3429,11 @@ package body Exp_Ch9 is Master_Id : Entity_Id; begin - -- Nothing to do if there is no task hierarchy + -- Nothing to do if tasks or tasking hierarchies are prohibited - if Restriction_Active (No_Task_Hierarchy) then + if Restriction_Active (No_Tasking) + or else Restriction_Active (No_Task_Hierarchy) + then return; end if; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index e4a2624..21f9ec5 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -375,7 +375,7 @@ package System.OS_Lib is function File_Time_Stamp (Name : String) return OS_Time; -- Given the name of a file or directory, Name, obtains and returns the -- time stamp. This function can be used for an unopened file. Returns - -- Invalid_Time is Name doesn't correspond to an existing file. + -- Invalid_Time if Name doesn't correspond to an existing file. function File_Time_Stamp (FD : File_Descriptor) return OS_Time; -- Get time stamp of file from file descriptor FD Returns Invalid_Time is @@ -662,8 +662,6 @@ package System.OS_Lib is -- This subtype is used to document that a parameter is the address of a -- null-terminated string containing the name of a file. - -- All the following functions need comments ??? - procedure Copy_File (Name : C_File_Name; Pathname : C_File_Name; @@ -687,7 +685,6 @@ package System.OS_Lib is procedure Delete_File (Name : C_File_Name; Success : out Boolean); function File_Time_Stamp (Name : C_File_Name) return OS_Time; - -- Returns Invalid_Time is Name doesn't correspond to an existing file function Is_Directory (Name : C_File_Name) return Boolean; function Is_Executable_File (Name : C_File_Name) return Boolean; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 70b4a36..d125bf2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -632,7 +632,7 @@ package body Sem_Ch6 is -- Function result subtype procedure Check_Aggregate_Accessibility (Aggr : Node_Id); - -- Apply legality rule of 6.5 (8.2) to the access discriminants of an + -- Apply legality rule of 6.5 (5.8) to the access discriminants of an -- aggregate in a return statement. procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); @@ -2225,6 +2225,11 @@ package body Sem_Ch6 is -- limited views with the non-limited ones. Return the list of changes -- to be used to undo the transformation. + procedure Freeze_Expr_Types (Spec_Id : Entity_Id); + -- (AI12-0103) N is the body associated with an expression function that + -- is a completion, and Spec_Id its defining entity. Freeze before N all + -- the types referenced by the expression of the function. + function Is_Private_Concurrent_Primitive (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id is a primitive of a concurrent @@ -2945,6 +2950,81 @@ package body Sem_Ch6 is return Result; end Exchange_Limited_Views; + ----------------------- + -- Freeze_Expr_Types -- + ----------------------- + + procedure Freeze_Expr_Types (Spec_Id : Entity_Id) is + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result; + -- Freeze all types referenced in the subtree rooted at Node + + ---------------------- + -- Freeze_Type_Refs -- + ---------------------- + + function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is + begin + if Nkind (Node) = N_Identifier + and then Present (Entity (Node)) + then + if Is_Type (Entity (Node)) then + Freeze_Before (N, Entity (Node)); + + elsif Ekind_In (Entity (Node), E_Component, + E_Discriminant) + then + Freeze_Before (N, Scope (Entity (Node))); + end if; + end if; + + return OK; + end Freeze_Type_Refs; + + procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs); + + -- Local variables + + Return_Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + Dup_Expr : constant Node_Id := + New_Copy_Tree (Expression (Return_Stmt)); + + Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id); + Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id); + + -- Start of processing for Freeze_Expr_Types + + begin + pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement); + + -- Preanalyze a duplicate of the expression to have available the + -- minimum decoration needed to locate referenced unfrozen types + -- without adding any decoration to the function expression. This + -- preanalysis is performed with errors disabled to avoid reporting + -- spurious errors on Ghost entities (since the expression is not + -- fully analyzed). + + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); + Ignore_Errors_Enable := Ignore_Errors_Enable + 1; + + Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id)); + + Ignore_Errors_Enable := Ignore_Errors_Enable - 1; + End_Scope; + + -- Restore certain attributes of Spec_Id since the preanalysis may + -- have introduced itypes to this scope, thus modifying attributes + -- First_Entity and Last_Entity. + + Set_First_Entity (Spec_Id, Saved_First_Entity); + Set_Last_Entity (Spec_Id, Saved_Last_Entity); + + -- Freeze all types referenced in the expression + + Freeze_References (Dup_Expr); + end Freeze_Expr_Types; + ------------------------------------- -- Is_Private_Concurrent_Primitive -- ------------------------------------- @@ -3398,6 +3478,15 @@ package body Sem_Ch6 is then Set_Has_Delayed_Freeze (Spec_Id); Freeze_Before (N, Spec_Id); + + -- At the occurrence of an expression function declaration that is + -- a completion, its expression causes freezing (AI12-0103). + + if Has_Completion (Spec_Id) + and then Was_Expression_Function (N) + then + Freeze_Expr_Types (Spec_Id); + end if; end if; end if; |