diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 48 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
8 files changed, 149 insertions, 75 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e05fcaa..10a61b8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2017-01-23 Pascal Obry <obry@adacore.com> + + * s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which + is needed when a foreign thread call a Win32 API using a thread handle + like GetThreadTimes() for example. + +2017-01-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not + allow an 'Address clause to be specified on a prefix of a + class-wide type. + +2017-01-23 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Insert_Valid_Check): Ensure that the prefix of + attribute 'Valid is a renaming of the original expression when + the expression denotes a name. For all other kinds of expression, + use a constant to capture the value. + * exp_util.adb (Is_Name_Reference): Moved to Sem_Util. + * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util. + +2017-01-23 Justin Squirek <squirek@adacore.com> + + * sem_eval.adb (Eval_Integer_Literal): Add special + case to avoid optimizing out check if the literal appears in + an if-expression. + +2017-01-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not + allow an 'Address clause to be specified on a prefix of a + class-wide type. + +2017-01-23 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Insert_Valid_Check): Ensure that the prefix of + attribute 'Valid is a renaming of the original expression when + the expression denotes a name. For all other kinds of expression, + use a constant to capture the value. + * exp_util.adb (Is_Name_Reference): Moved to Sem_Util. + * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util. + +2017-01-23 Justin Squirek <squirek@adacore.com> + + * sem_eval.adb (Eval_Integer_Literal): Add special + case to avoid optimizing out check if the literal appears in + an if-expression. + 2017-01-23 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Try_Primitive_Operations, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 7f4a589..011878eb 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7206,12 +7206,18 @@ package body Checks is Force_Evaluation (Exp, Name_Req => False); end if; - -- Build the prefix for the 'Valid call + -- Build the prefix for the 'Valid call. If the expression denotes + -- a name, use a renaming to alias it, otherwise use a constant to + -- capture the value of the expression. + + -- Temp : ... renames Expr; -- reference to a name + -- Temp : constant ... := Expr; -- all other cases PV := Duplicate_Subexpr_No_Checks (Exp => Exp, Name_Req => False, + Renaming_Req => Is_Name_Reference (Exp), Related_Id => Related_Id, Is_Low_Bound => Is_Low_Bound, Is_High_Bound => Is_High_Bound); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e828a1e..a0b0eda 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9014,12 +9014,6 @@ package body Exp_Util is -- is present (xxx is taken from the Chars field of Related_Nod), -- otherwise it generates an internal temporary. - function Is_Name_Reference (N : Node_Id) return Boolean; - -- Determine if the tree referenced by N represents a name. This is - -- similar to Is_Object_Reference but returns true only if N can be - -- renamed without the need for a temporary, the typical example of - -- an object not in this category being a function call. - --------------------- -- Build_Temporary -- --------------------- @@ -9050,61 +9044,6 @@ package body Exp_Util is end if; end Build_Temporary; - ----------------------- - -- Is_Name_Reference -- - ----------------------- - - function Is_Name_Reference (N : Node_Id) return Boolean is - begin - if Is_Entity_Name (N) then - return Present (Entity (N)) and then Is_Object (Entity (N)); - end if; - - case Nkind (N) is - when N_Indexed_Component - | N_Slice - => - return - Is_Name_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N))); - - -- Attributes 'Input, 'Old and 'Result produce objects - - when N_Attribute_Reference => - return - Nam_In - (Attribute_Name (N), Name_Input, Name_Old, Name_Result); - - when N_Selected_Component => - return - Is_Name_Reference (Selector_Name (N)) - and then - (Is_Name_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); - - when N_Explicit_Dereference => - return True; - - -- A view conversion of a tagged name is a name reference - - when N_Type_Conversion => - return - Is_Tagged_Type (Etype (Subtype_Mark (N))) - and then Is_Tagged_Type (Etype (Expression (N))) - and then Is_Name_Reference (Expression (N)); - - -- An unchecked type conversion is considered to be a name if - -- the operand is a name (this construction arises only as a - -- result of expansion activities). - - when N_Unchecked_Type_Conversion => - return Is_Name_Reference (Expression (N)); - - when others => - return False; - end case; - end Is_Name_Reference; - -- Local variables Loc : constant Source_Ptr := Sloc (Exp); diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index c945e1d..aba2367 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -157,11 +157,19 @@ package body System.Task_Primitives.Operations is package body Specific is + ------------------- + -- Is_Valid_Task -- + ------------------- + function Is_Valid_Task return Boolean is begin return TlsGetValue (TlsIndex) /= System.Null_Address; end Is_Valid_Task; + --------- + -- Set -- + --------- + procedure Set (Self_Id : Task_Id) is Succeeded : BOOL; begin @@ -761,13 +769,9 @@ package body System.Task_Primitives.Operations is -- 1) from System.Task_Primitives.Operations.Initialize -- 2) from System.Tasking.Stages.Task_Wrapper - -- The thread initialisation has to be done only for the first case - - -- This is because the GetCurrentThread NT call does not return the real - -- thread handler but only a "pseudo" one. It is not possible to release - -- the thread handle and free the system resources from this "pseudo" - -- handle. So we really want to keep the real thread handle set in - -- System.Task_Primitives.Operations.Create_Task during thread creation. + -- The pseudo handle (LL.Thread) need not be closed when it is no + -- longer needed. Calling the CloseHandle function with this handle + -- has no effect. procedure Enter_Task (Self_ID : Task_Id) is procedure Get_Stack_Bounds (Base : Address; Limit : Address); @@ -787,6 +791,7 @@ package body System.Task_Primitives.Operations is raise Invalid_CPU_Number; end if; + Self_ID.Common.LL.Thread := GetCurrentThread; Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; Get_Stack_Bounds @@ -887,8 +892,8 @@ package body System.Task_Primitives.Operations is DWORD (Stack_Size), Entry_Point, pTaskParameter, - DWORD (Create_Suspended) or - DWORD (Stack_Size_Param_Is_A_Reservation), + DWORD (Create_Suspended) + or DWORD (Stack_Size_Param_Is_A_Reservation), TaskId'Unchecked_Access); else hTask := CreateThread diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index db0b1d8..f8078ff 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4915,7 +4915,20 @@ package body Sem_Ch13 is or else Has_Controlled_Component (Etype (U_Ent)) then Error_Msg_NE - ("??controlled object& must not be overlaid", Nam, U_Ent); + ("??controlled object & must not be overlaid", Nam, U_Ent); + Error_Msg_N + ("\??Program_Error will be raised at run time", Nam); + Insert_Action (Declaration_Node (U_Ent), + Make_Raise_Program_Error (Loc, + Reason => PE_Overlaid_Controlled_Object)); + return; + + -- Case of an address clause for a class-wide object which is + -- considered erroneous. + + elsif Is_Class_Wide_Type (Etype (U_Ent)) then + Error_Msg_NE + ("??class-wide object & must not be overlaid", Nam, U_Ent); Error_Msg_N ("\??Program_Error will be raised at run time", Nam); Insert_Action (Declaration_Node (U_Ent), diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 0d135cf..6e56e1d 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2682,9 +2682,12 @@ package body Sem_Eval is -- If the literal appears in a non-expression context, then it is -- certainly appearing in a non-static context, so check it. This is -- actually a redundant check, since Check_Non_Static_Context would - -- check it, but it seems worth while avoiding the call. + -- check it, but it seems worth while to optimize out the call. - if Nkind (Parent (N)) not in N_Subexpr + -- An exception is made for a literal in an if or case expression + + if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative) + or else Nkind (Parent (N)) not in N_Subexpr) and then not In_Any_Integer_Context then Check_Non_Static_Context (N); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 752a69b..fd45a38 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13405,6 +13405,60 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; + ----------------------- + -- Is_Name_Reference -- + ----------------------- + + function Is_Name_Reference (N : Node_Id) return Boolean is + begin + if Is_Entity_Name (N) then + return Present (Entity (N)) and then Is_Object (Entity (N)); + end if; + + case Nkind (N) is + when N_Indexed_Component + | N_Slice + => + return + Is_Name_Reference (Prefix (N)) + or else Is_Access_Type (Etype (Prefix (N))); + + -- Attributes 'Input, 'Old and 'Result produce objects + + when N_Attribute_Reference => + return + Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); + + when N_Selected_Component => + return + Is_Name_Reference (Selector_Name (N)) + and then + (Is_Name_Reference (Prefix (N)) + or else Is_Access_Type (Etype (Prefix (N)))); + + when N_Explicit_Dereference => + return True; + + -- A view conversion of a tagged name is a name reference + + when N_Type_Conversion => + return + Is_Tagged_Type (Etype (Subtype_Mark (N))) + and then Is_Tagged_Type (Etype (Expression (N))) + and then Is_Name_Reference (Expression (N)); + + -- An unchecked type conversion is considered to be a name if the + -- operand is a name (this construction arises only as a result of + -- expansion activities). + + when N_Unchecked_Type_Conversion => + return Is_Name_Reference (Expression (N)); + + when others => + return False; + end case; + end Is_Name_Reference; + --------------------------------- -- Is_Nontrivial_DIC_Procedure -- --------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d084800..42d51a5 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1548,6 +1548,12 @@ package Sem_Util is -- parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? + function Is_Name_Reference (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N is a reference to a name. This is + -- similar to Is_Object_Reference but returns True only if N can be renamed + -- without the need for a temporary, the typical example of an object not + -- in this category being a function call. + function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean; -- Determine whether entity Id denotes the procedure that verifies the -- assertion expression of pragma Default_Initial_Condition and if it does, |