From 84dad5564e15efedd6e41950ae856ec3bb201052 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 12 May 2015 10:07:41 +0200 Subject: [PATCH] [multiple changes] 2015-05-12 Robert Dewar * exp_unst.adb (Get_Real_Subp): New subprogram. (Unnest_Subprogram): Use Get_Real_Subp. (Uplev_Refs_For_One_Subp): Skip if no ARECnU entity. (Uplev_Refs_For_One_Subp): Use actual subtype in unconstrained case. 2015-05-12 Robert Dewar * a-reatim.adb ("/"): Add explicit check for Time_Span_First / -1. 2015-05-12 Ed Schonberg * sem_ch4.adb (Extended_Primitive_Ops): New subprogram, auxiliary to Try_Primitive_Operation to handle properly prefixed calls where the operation is not a primitive of the type, but is declared in the package body that is in the immediate scope of the type. From-SVN: r223036 --- gcc/ada/ChangeLog | 19 ++++++++ gcc/ada/a-reatim.adb | 12 +++++- gcc/ada/exp_unst.adb | 66 +++++++++++++++++++++++++--- gcc/ada/sem_ch4.adb | 120 +++++++++++++++++++++++++++++++++++++++------------ 4 files changed, 182 insertions(+), 35 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c711823259e..e2666c62709 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,24 @@ 2015-05-12 Robert Dewar + * exp_unst.adb (Get_Real_Subp): New subprogram. + (Unnest_Subprogram): Use Get_Real_Subp. + (Uplev_Refs_For_One_Subp): Skip if no ARECnU entity. + (Uplev_Refs_For_One_Subp): Use actual subtype in unconstrained case. + +2015-05-12 Robert Dewar + + * a-reatim.adb ("/"): Add explicit check for Time_Span_First / -1. + +2015-05-12 Ed Schonberg + + * sem_ch4.adb (Extended_Primitive_Ops): New subprogram, + auxiliary to Try_Primitive_Operation to handle properly prefixed + calls where the operation is not a primitive of the type, but + is declared in the package body that is in the immediate scope + of the type. + +2015-05-12 Robert Dewar + * sem_util.adb (Is_Variable): Allow X'Deref(Y) as a variable. 2015-05-12 Ed Schonberg diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 4597dc3b5a7..52aa9f3a372 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2015, AdaCore -- -- -- -- 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- -- @@ -123,6 +123,16 @@ package body Ada.Real_Time is pragma Unsuppress (Overflow_Check); pragma Unsuppress (Division_Check); begin + -- Even though checks are unsuppressed, we need an explicit check for + -- the case of largest negative integer divided by minus one, since + -- some library routines we use fail to catch this case. This will be + -- fixed at the compiler level in the future, at which point this test + -- can be removed. + + if Left = Time_Span_First and then Right = -1 then + raise Constraint_Error with "overflow"; + end if; + return Time_Span (Duration (Left) / Right); end "/"; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index eed99ffc8df..446f3fc4e4a 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -1116,9 +1116,48 @@ package body Exp_Unst is -- Process uplevel references for one subprogram - declare + Uplev_Refs_For_One_Subp : declare Elmt : Elmt_Id; + function Get_Real_Subp (Ent : Entity_Id) return Entity_Id; + -- The entity recorded as the enclosing subprogram for the + -- reference sometimes turns out to be a subprogram body. + -- This function gets the proper subprogram spec if needed. + + ------------------- + -- Get_Real_Subp -- + ------------------- + + function Get_Real_Subp (Ent : Entity_Id) return Entity_Id is + Nod : Node_Id; + + begin + -- If we have a subprogram, return it + + if Is_Subprogram (Ent) then + return Ent; + + -- If we have a subprogram body, go to the body + + elsif Ekind (Ent) = E_Subprogram_Body then + Nod := Parent (Parent (Ent)); + pragma Assert (Nkind (Nod) = N_Subprogram_Body); + + if Acts_As_Spec (Nod) then + return Ent; + else + return Corresponding_Spec (Nod); + end if; + + -- Should not be any other possibilities + + else + raise Program_Error; + end if; + end Get_Real_Subp; + + -- Start of processing for Uplevel_References_For_One_Subp + begin -- Loop through uplevel references @@ -1127,7 +1166,7 @@ package body Exp_Unst is -- Rewrite one reference - declare + Rewrite_One_Ref : declare Ref : constant Node_Id := Actual_Ref (Node (Elmt)); -- The reference to be rewritten @@ -1140,8 +1179,11 @@ package body Exp_Unst is Typ : constant Entity_Id := Etype (Ent); -- The type of the referenced entity + Atyp : constant Entity_Id := Get_Actual_Subtype (Ref); + -- The actual subtype of the reference + Rsub : constant Entity_Id := - Node (Next_Elmt (Elmt)); + Get_Real_Subp (Node (Next_Elmt (Elmt))); -- The enclosing subprogram for the reference RSX : constant SI_Type := Subp_Index (Rsub); @@ -1155,6 +1197,17 @@ package body Exp_Unst is SI : SI_Type; begin + -- Ignore if no ARECnF entity for enclosing subprogram + -- which probably happens as a result of not properly + -- treating instance bodies. To be examined ??? + + -- If this test is omitted, then the compilation of + -- freeze.adb and inline.adb fail in unnesting mode. + + if No (STJR.ARECnF) then + goto Continue; + end if; + -- Push the current scope, so that the pointer type -- Tnn, and any subsidiary entities resulting from -- the analysis of the rewritten reference, go in the @@ -1215,7 +1268,7 @@ package body Exp_Unst is Rewrite (Ref, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Atyp, Loc), Attribute_Name => Name_Deref, Expressions => New_List ( Make_Selected_Component (Loc, @@ -1240,12 +1293,13 @@ package body Exp_Unst is Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks); Opt.Unnest_Subprogram_Mode := True; Pop_Scope; - end; + end Rewrite_One_Ref; + <> Next_Elmt (Elmt); Next_Elmt (Elmt); end loop; - end; + end Uplev_Refs_For_One_Subp; end if; end; end loop Uplev_Refs; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c943df19b16..6fb250c9461 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -210,12 +210,12 @@ package body Sem_Ch4 is (T1, T2 : Entity_Id; Op_Id : Entity_Id; N : Node_Id); - -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid - -- types for left and right operand. Determine whether they constitute - -- a valid pair for the given operator, and record the corresponding - -- interpretation of the operator node. The node N may be an operator - -- node (the usual case) or a function call whose prefix is an operator - -- designator. In both cases Op_Id is the operator name itself. + -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types + -- for left and right operand. Determine whether they constitute a valid + -- pair for the given operator, and record the corresponding interpretation + -- of the operator node. The node N may be an operator node (the usual + -- case) or a function call whose prefix is an operator designator. In + -- both cases Op_Id is the operator name itself. procedure Diagnose_Call (N : Node_Id; Nam : Node_Id); -- Give detailed information on overloaded call where none of the @@ -242,6 +242,7 @@ package body Sem_Ch4 is -- object E. The function returns the designated type of the prefix, taking -- into account that the designated type of an anonymous access type may be -- a limited view, when the non-limited view is visible. + -- -- If in semantics only mode (-gnatc or generic), the function also records -- that the prefix is a reference to E, if any. Normally, such a reference -- is generated only when the implicit dereference is expanded into an @@ -285,7 +286,7 @@ package body Sem_Ch4 is -- Ada 2005 (AI-252): Support the object.operation notation. If node N -- is a call in this notation, it is transformed into a normal subprogram -- call where the prefix is a parameter, and True is returned. If node - -- N is not of this form, it is unchanged, and False is returned. if + -- N is not of this form, it is unchanged, and False is returned. If -- CW_Test_Only is true then N is an N_Selected_Component node which -- is part of a call to an entry or procedure of a tagged concurrent -- type and this routine is invoked to search for class-wide subprograms @@ -315,8 +316,10 @@ package body Sem_Ch4 is if Is_Overloaded (Opnd) then if Nkind (Opnd) in N_Op then Nam := Opnd; + elsif Nkind (Opnd) = N_Function_Call then Nam := Name (Opnd); + elsif Ada_Version >= Ada_2012 then declare It : Interp; @@ -343,7 +346,8 @@ package body Sem_Ch4 is end if; if Opnd = Left_Opnd (N) then - Error_Msg_N ("\left operand has the following interpretations", N); + Error_Msg_N + ("\left operand has the following interpretations", N); else Error_Msg_N ("\right operand has the following interpretations", N); @@ -606,7 +610,7 @@ package body Sem_Ch4 is Type_Id := Process_Subtype (E, N); Acc_Type := Create_Itype (E_Allocator_Type, N); - Set_Etype (Acc_Type, Acc_Type); + Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); @@ -681,21 +685,21 @@ package body Sem_Ch4 is else Error_Msg_N - ("uninitialized unconstrained allocation not allowed", - N); + ("uninitialized unconstrained allocation not " + & "allowed", N); if Is_Array_Type (Type_Id) then Error_Msg_N - ("\qualified expression or constraint with " & - "array bounds required", N); + ("\qualified expression or constraint with " + & "array bounds required", N); elsif Has_Unknown_Discriminants (Type_Id) then Error_Msg_N ("\qualified expression required", N); else pragma Assert (Has_Discriminants (Type_Id)); Error_Msg_N - ("\qualified expression or constraint with " & - "discriminant values required", N); + ("\qualified expression or constraint with " + & "discriminant values required", N); end if; end if; end if; @@ -804,9 +808,9 @@ package body Sem_Ch4 is -- Entity is not already set, so we do need to collect interpretations else - Op_Id := Get_Name_Entity_Id (Chars (N)); Set_Etype (N, Any_Type); + Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator and then Present (Next_Entity (First_Entity (Op_Id))) @@ -889,6 +893,7 @@ package body Sem_Ch4 is Actual); exit; end if; + when others => Named_Seen := True; end case; @@ -905,10 +910,8 @@ package body Sem_Ch4 is begin if Is_Entity_Name (Nam) then return Ekind (Entity (Nam)) = E_Function; - elsif Nkind (Nam) = N_Selected_Component then return Ekind (Entity (Selector_Name (Nam))) = E_Function; - else return False; end if; @@ -932,8 +935,7 @@ package body Sem_Ch4 is ("must instantiate generic procedure& before call", Nam, Entity (Nam)); else - Error_Msg_N - ("procedure or entry name expected", Nam); + Error_Msg_N ("procedure or entry name expected", Nam); end if; -- Check for tasking cases where only an entry call will do @@ -1101,7 +1103,6 @@ package body Sem_Ch4 is end if; Get_First_Interp (Nam, X, It); - while Present (It.Nam) loop Nam_Ent := It.Nam; Deref := False; @@ -1359,7 +1360,6 @@ package body Sem_Ch4 is if No (Alt) then Add_One_Interp (N, It.Typ, It.Typ); - else Wrong_Alt := Alt; end if; @@ -1685,11 +1685,11 @@ package body Sem_Ch4 is end loop; end if; - -- If there was no match, and the operator is inequality, this may - -- be a case where inequality has not been made explicit, as for - -- tagged types. Analyze the node as the negation of an equality - -- operation. This cannot be done earlier, because before analysis - -- we cannot rule out the presence of an explicit inequality. + -- If there was no match, and the operator is inequality, this may be + -- a case where inequality has not been made explicit, as for tagged + -- types. Analyze the node as the negation of an equality operation. + -- This cannot be done earlier, because before analysis we cannot rule + -- out the presence of an explicit inequality. if Etype (N) = Any_Type and then Nkind (N) = N_Op_Ne @@ -8060,6 +8060,15 @@ package body Sem_Ch4 is -- subprogram because that list starts with the subprogram formals. -- We retrieve the candidate operations from the generic declaration. + function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id; + -- Prefix notation can also be used on operations that are not + -- primitives of the type, but are declared in the same immediate + -- declarative part, which can only mean the corresponding package + -- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the + -- list of primitives with body operations with the same name that + -- may be candidates, so that Try_Primitive_Operations can examine + -- them if no real primitive is found. + function Is_Private_Overriding (Op : Entity_Id) return Boolean; -- An operation that overrides an inherited operation in the private -- part of its package may be hidden, but if the inherited operation @@ -8166,6 +8175,61 @@ package body Sem_Ch4 is end if; end Collect_Generic_Type_Ops; + ---------------------------- + -- Extended_Primitive_Ops -- + ---------------------------- + + function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is + Type_Scope : constant Entity_Id := Scope (T); + + Body_Decls : List_Id; + Op_Found : Boolean; + Op : Entity_Id; + Op_List : Elist_Id; + + begin + Op_List := Primitive_Operations (T); + + if Ekind (Type_Scope) = E_Package + and then In_Package_Body (Type_Scope) + and then In_Open_Scopes (Type_Scope) + then + -- Retrieve list of declarations of package body. + + Body_Decls := + Declarations + (Unit_Declaration_Node + (Corresponding_Body + (Unit_Declaration_Node (Type_Scope)))); + + Op := Current_Entity (Subprog); + Op_Found := False; + while Present (Op) loop + if Comes_From_Source (Op) + and then Is_Overloadable (Op) + and then Is_List_Member (Unit_Declaration_Node (Op)) + and then List_Containing (Unit_Declaration_Node (Op)) = + Body_Decls + then + if not Op_Found then + + -- Copy list of primitives so it is not affected for + -- other uses. + + Op_List := New_Copy_Elist (Op_List); + Op_Found := True; + end if; + + Append_Elmt (Op, Op_List); + end if; + + Op := Homonym (Op); + end loop; + end if; + + return Op_List; + end Extended_Primitive_Ops; + --------------------------- -- Is_Private_Overriding -- --------------------------- @@ -8237,7 +8301,7 @@ package body Sem_Ch4 is elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; - Elmt := First_Elmt (Primitive_Operations (Obj_Type)); + Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type)); else Corr_Type := Obj_Type; -- 2.11.4.GIT