From fa73fc3d39956ebf22998dea8bffa96fad34d6f2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 26 Oct 2015 14:10:12 +0100 Subject: [PATCH] [multiple changes] 2015-10-26 Jerome Lambourg * sysdep.c (__gnat_get_task_options): Workaround a VxWorks bug where VX_DEALLOC_TCB task option is forbidden when calling taskCreate but allowed in VX_USR_TASK_OPTIONS. 2015-10-26 Javier Miranda * exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): New subprogram. 2015-10-26 Ed Schonberg * sem_ch4.adb (Constant_Indexing_OK): New predicate, subsidiary of Try_Container_Indexing, that implements the name resolution rules given in RM 4.1.6 (13-15). From-SVN: r229355 --- gcc/ada/ChangeLog | 16 +++++ gcc/ada/exp_unst.adb | 15 ++++ gcc/ada/exp_unst.ads | 3 + gcc/ada/sem_ch4.adb | 168 ++++++++++++++++++++++++++++++++++++++----- gcc/ada/sysdep.c | 15 +++- 5 files changed, 195 insertions(+), 22 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ce0053b4c7..6b12af25005 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2015-10-26 Jerome Lambourg + + * sysdep.c (__gnat_get_task_options): Workaround a VxWorks + bug where VX_DEALLOC_TCB task option is forbidden when calling + taskCreate but allowed in VX_USR_TASK_OPTIONS. + +2015-10-26 Javier Miranda + + * exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): New subprogram. + +2015-10-26 Ed Schonberg + + * sem_ch4.adb (Constant_Indexing_OK): New predicate, subsidiary + of Try_Container_Indexing, that implements the name resolution + rules given in RM 4.1.6 (13-15). + 2015-10-26 Hristian Kirtchev * sem_ch3.adb, sem_util.adb: Minor reformatting. diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 52214726442..b555fe70561 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -119,6 +119,21 @@ package body Exp_Unst is Table_Increment => 200, Table_Name => "Unnest_Urefs"); + --------------------------- + -- Is_Uplevel_Referenced -- + --------------------------- + + function Is_Uplevel_Referenced (E : Entity_Id) return Boolean is + begin + for J in Urefs.First .. Urefs.Last loop + if Urefs.Table (J).Ent = E then + return True; + end if; + end loop; + + return False; + end Is_Uplevel_Referenced; + ----------------------- -- Unnest_Subprogram -- ----------------------- diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 084e904b677..1458853610c 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -686,4 +686,7 @@ package Exp_Unst is -- adds the ARECP parameter to all nested subprograms which need it, and -- modifies all uplevel references appropriately. + function Is_Uplevel_Referenced (E : Entity_Id) return Boolean; + -- Determines if E has some uplevel reference from a nested subprogram + end Exp_Unst; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3b55ea3971f..c354de8a498 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7161,18 +7161,147 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is + function Constant_Indexing_OK return Boolean; + -- Constant_Indexing is legal if there is no Variable_Indexing defined + -- for the type, or else node not a target of assignment, or an actual + -- for an IN OUT or OUT formal (RM 4.1.6 (11)). + + -------------------------- + -- Constant_Indexing_OK -- + -------------------------- + + function Constant_Indexing_OK return Boolean is + Par : Node_Id; + + begin + if No (Find_Value_Of_Aspect + (Etype (Prefix), Aspect_Variable_Indexing)) + then + return True; + + elsif not Is_Variable (Prefix) then + return True; + end if; + + Par := N; + while Present (Par) loop + if Nkind (Parent (Par)) = N_Assignment_Statement + and then Par = Name (Parent (Par)) + then + return False; + + -- The call may be overloaded, in which case we assume that its + -- resolution does not depend on the type of the parameter that + -- includes the indexing operation. + + elsif Nkind_In (Parent (Par), N_Function_Call, + N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Parent (Par))) + then + declare + Actual : Node_Id; + Formal : Entity_Id; + Proc : Entity_Id; + + begin + -- We should look for an interpretation with the proper + -- number of formals, and determine whether it is an + -- In_Parameter, but for now assume that in the overloaded + -- case constant indexing is legal. To be improved ??? + + if Is_Overloaded (Name (Parent (Par))) then + return True; + + else + Proc := Entity (Name (Parent (Par))); + + -- If this is an indirect call, get formals from + -- designated type. + + if Is_Access_Subprogram_Type (Etype (Proc)) then + Proc := Designated_Type (Etype (Proc)); + end if; + end if; + + Formal := First_Formal (Proc); + Actual := First_Actual (Parent (Par)); + + -- Find corresponding actual + + while Present (Actual) loop + exit when Actual = Par; + Next_Actual (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere. + + else + return False; + end if; + end loop; + + return Ekind (Formal) = E_In_Parameter; + end; + + elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then + return False; + + -- If the indexed component is a prefix it may be the first actual + -- of a prefixed call. Retrieve the called entity, if any, and + -- check its first formal. + + elsif Nkind (Parent (Par)) = N_Selected_Component then + declare + Sel : constant Node_Id := Selector_Name (Parent (Par)); + Nam : constant Entity_Id := Current_Entity (Sel); + + begin + if Present (Nam) + and then Is_Overloadable (Nam) + and then Present (First_Formal (Nam)) + then + return Ekind (First_Formal (Nam)) = E_In_Parameter; + end if; + end; + + elsif Nkind ((Par)) in N_Op then + return True; + end if; + + Par := Parent (Par); + end loop; + + -- In all other cases, constant indexing is legal + + return True; + end Constant_Indexing_OK; + + -- Local variables + Loc : constant Source_Ptr := Sloc (N); - C_Type : Entity_Id; Assoc : List_Id; + C_Type : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; Indexing : Node_Id; + -- Start of processing for Try_Container_Indexing + begin + -- Node may have been analyzed already when testing for a prefixed + -- call, in which case do not redo analysis. + + if Present (Generalized_Indexing (N)) then + return True; + end if; + C_Type := Etype (Prefix); - -- If indexing a class-wide container, obtain indexing primitive - -- from specific type. + -- If indexing a class-wide container, obtain indexing primitive from + -- specific type. if Is_Class_Wide_Type (C_Type) then C_Type := Etype (Base_Type (C_Type)); @@ -7182,14 +7311,14 @@ package body Sem_Ch4 is Func_Name := Empty; - if Is_Variable (Prefix) then + if Constant_Indexing_OK then Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); end if; if No (Func_Name) then Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); end if; -- If aspect does not exist the expression is illegal. Error is @@ -7197,8 +7326,8 @@ package body Sem_Ch4 is if No (Func_Name) then - -- The prefix itself may be an indexing of a container: rewrite - -- as such and re-analyze. + -- The prefix itself may be an indexing of a container: rewrite as + -- such and re-analyze. if Has_Implicit_Dereference (Etype (Prefix)) then Build_Explicit_Dereference @@ -7213,14 +7342,14 @@ package body Sem_Ch4 is -- value of the inherited aspect is the Reference operation declared -- for the parent type. - -- However, Reference is also a primitive operation of the type, and - -- the inherited operation has a different signature. We retrieve the - -- right ones (the function may be overloaded) from the list of - -- primitive operations of the derived type. + -- However, Reference is also a primitive operation of the type, and the + -- inherited operation has a different signature. We retrieve the right + -- ones (the function may be overloaded) from the list of primitive + -- operations of the derived type. - -- Note that predefined containers are typically all derived from one - -- of the Controlled types. The code below is motivated by containers - -- that are derived from other types with a Reference aspect. + -- Note that predefined containers are typically all derived from one of + -- the Controlled types. The code below is motivated by containers that + -- are derived from other types with a Reference aspect. elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) @@ -7238,8 +7367,8 @@ package body Sem_Ch4 is -- The generalized indexing node is the one on which analysis and -- resolution take place. Before expansion the original node is replaced - -- with the generalized indexing node, which is a call, possibly with - -- a dereference operation. + -- with the generalized indexing node, which is a call, possibly with a + -- dereference operation. if Comes_From_Source (N) then Check_Compiler_Unit ("generalized indexing", N); @@ -7279,7 +7408,8 @@ package body Sem_Ch4 is else Indexing := Make_Function_Call (Loc, - Name => Make_Identifier (Loc, Chars (Func_Name)), + Name => + Make_Identifier (Loc, Chars (Func_Name)), Parameter_Associations => Assoc); Set_Parent (Indexing, Parent (N)); @@ -7297,7 +7427,7 @@ package body Sem_Ch4 is Analyze_One_Call (Indexing, It.Nam, False, Success); if Success then - Set_Etype (Name (Indexing), It.Typ); + Set_Etype (Name (Indexing), It.Typ); Set_Entity (Name (Indexing), It.Nam); Set_Etype (N, Etype (Indexing)); diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 01dae2bf1fc..21cd37cc540 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -865,10 +865,19 @@ __gnat_get_task_options (void) /* Mask those bits that are not under user control */ #ifdef VX_USR_TASK_OPTIONS - return options & VX_USR_TASK_OPTIONS; -#else - return options; + /* O810-007, TSR 00043679: + Workaround a bug in Vx-7 where VX_DEALLOC_TCB == VX_PRIVATE_UMASK and: + - VX_DEALLOC_TCB is an internal option not to be used by users + - VX_PRIVATE_UMASK as a user-definable option + This leads to VX_USR_TASK_OPTIONS allowing 0x8000 as VX_PRIVATE_UMASK but + taskCreate refusing this option (VX_DEALLOC_TCB is not allowed) + */ +# if defined (VX_PRIVATE_UMASK) && (VX_DEALLOC_TCB == VX_PRIVATE_UMASK) + options &= ~VX_DEALLOC_TCB; +# endif + options &= VX_USR_TASK_OPTIONS; #endif + return options; } #endif -- 2.30.2