From 362e5ece36cab6ff1252ef2a6d19d790f12b1a6c Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 23 Jan 2012 09:39:27 +0000 Subject: [PATCH] 2012-01-23 Hristian Kirtchev * sem_ch12.adb (Analyze_Associations): Alphabetize local variables and constants. Rename Actual_Types to Actuals_To_Freeze. Rename Next_Formal to Saved_Formal. Freeze all eligible subprograms which appear as actuals in the instantiation. (Has_Fully_Defined_Profile): New routine. (Renames_Standard_Subprogram): New routine. (Earlier): Add local variable N. Comment update. Do not use source locations when trying to determine whether one node precedes another. 2012-01-23 Gary Dismukes * exp_ch4.adb (Expand_Concatenate): In the case where the result of a concatentation can be null, set the to result have both the low and high bounds of the right operand (not just the high bound, as was the case prior to this fix). Also, fix the saved high bound setting (Last_Opnd_High_Bound) in the empty string literal case (should have been low bound minus one, rather than plus one). 2012-01-23 Thomas Quinot * scos.ads, put_scos.adb, get_scos.adb (Get_SCOs, Put_SCOs): Do not omit statement SCOs for disabled pragmas. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183419 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 27 +++++ gcc/ada/exp_ch4.adb | 39 ++++++- gcc/ada/get_scos.adb | 4 +- gcc/ada/put_scos.adb | 11 +- gcc/ada/scos.ads | 3 +- gcc/ada/sem_ch12.adb | 299 ++++++++++++++++++++++++++++++++++++++++++--------- 6 files changed, 318 insertions(+), 65 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b1ef51c0490..79c5b98c92b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2012-01-23 Hristian Kirtchev + + * sem_ch12.adb (Analyze_Associations): Alphabetize local variables and + constants. Rename Actual_Types to Actuals_To_Freeze. Rename Next_Formal + to Saved_Formal. + Freeze all eligible subprograms which appear as actuals in + the instantiation. + (Has_Fully_Defined_Profile): New routine. + (Renames_Standard_Subprogram): New routine. + (Earlier): Add local variable N. Comment update. Do not use source + locations when trying to determine whether one node precedes another. + +2012-01-23 Gary Dismukes + + * exp_ch4.adb (Expand_Concatenate): In the case + where the result of a concatentation can be null, set the to + result have both the low and high bounds of the right operand (not + just the high bound, as was the case prior to this fix). Also, + fix the saved high bound setting (Last_Opnd_High_Bound) in the + empty string literal case (should have been low bound minus one, + rather than plus one). + +2012-01-23 Thomas Quinot + + * scos.ads, put_scos.adb, get_scos.adb (Get_SCOs, Put_SCOs): Do not + omit statement SCOs for disabled pragmas. + 2012-01-23 Matthew Heaney * a-cohase.ads, a-cihase.ads, a-cbhase.ads, a-coorse.ads, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8082cb0c241..b0a65cf92da 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -2601,6 +2601,12 @@ package body Exp_Ch4 is -- This is either an integer literal node, or an identifier reference to -- a constant entity initialized to the appropriate value. + Last_Opnd_Low_Bound : Node_Id; + -- A tree node representing the low bound of the last operand. This + -- need only be set if the result could be null. It is used for the + -- special case of setting the right low bound for a null result. + -- This is of type Ityp. + Last_Opnd_High_Bound : Node_Id; -- A tree node representing the high bound of the last operand. This -- need only be set if the result could be null. It is used for the @@ -2811,11 +2817,14 @@ package body Exp_Ch4 is Result_May_Be_Null := False; end if; - -- Capture last operand high bound if result could be null + -- Capture last operand low and high bound if result could be null if J = N and then Result_May_Be_Null then + Last_Opnd_Low_Bound := + New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); + Last_Opnd_High_Bound := - Make_Op_Add (Loc, + Make_Op_Subtract (Loc, Left_Opnd => New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), Right_Opnd => Make_Integer_Literal (Loc, 1)); @@ -2871,9 +2880,13 @@ package body Exp_Ch4 is Result_May_Be_Null := False; end if; - -- Capture last operand bound if result could be null + -- Capture last operand bounds if result could be null if J = N and then Result_May_Be_Null then + Last_Opnd_Low_Bound := + Convert_To (Ityp, + Make_Integer_Literal (Loc, Expr_Value (Lo))); + Last_Opnd_High_Bound := Convert_To (Ityp, Make_Integer_Literal (Loc, Expr_Value (Hi))); @@ -2914,7 +2927,16 @@ package body Exp_Ch4 is Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_First); + -- Capture last operand bounds if result could be null + if J = N and Result_May_Be_Null then + Last_Opnd_Low_Bound := + Convert_To (Ityp, + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_First)); + Last_Opnd_High_Bound := Convert_To (Ityp, Make_Attribute_Reference (Loc, @@ -3124,6 +3146,15 @@ package body Exp_Ch4 is -- bounds if the last operand is super-flat). if Result_May_Be_Null then + Low_Bound := + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Artyp_Literal (0)), + Last_Opnd_Low_Bound, + Low_Bound)); + High_Bound := Make_Conditional_Expression (Loc, Expressions => New_List ( diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index e096c23ccf6..ce662ce7e64 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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- -- @@ -301,7 +301,7 @@ begin when others => Skipc; - if Typ = 'P' then + if Typ = 'P' or else Typ = 'p' then if Nextc not in '1' .. '9' then N := 1; loop diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 84d4ef60e79..39fd04fcc7a 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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- -- @@ -139,12 +139,6 @@ begin Ctr := 0; Continuation := False; loop - if SCO_Pragma_Disabled - (SCO_Table.Table (Start).Pragma_Sloc) - then - goto Next_Statement; - end if; - if Ctr = 0 then Write_SCO_Initiate (U); if not Continuation then @@ -169,7 +163,7 @@ begin Write_Info_Char (Sent.C2); if Sent.C1 = 'S' - and then Sent.C2 = 'P' + and then (Sent.C2 = 'P' or else Sent.C2 = 'p') and then Sent.Pragma_Name /= Unknown_Pragma then -- Strip leading "PRAGMA_" @@ -205,7 +199,6 @@ begin Ctr := 0; end if; - <> exit when SCO_Table.Table (Start).Last; Start := Start + 1; end loop; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index af4ebca761a..e0e31b66673 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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- -- @@ -157,6 +157,7 @@ package SCOs is -- F FOR loop (from FOR through end of iteration scheme) -- I IF statement (from IF through end of condition) -- P[name:] PRAGMA with the indicated name + -- p[name:] disabled PRAGMA with the indicated name -- R extended RETURN statement -- W WHILE loop statement (from WHILE through end of condition) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 31c92935b79..3624385e864 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -917,20 +917,20 @@ package body Sem_Ch12 is Formals : List_Id; F_Copy : List_Id) return List_Id is - Actual_Types : constant Elist_Id := New_Elmt_List; - Assoc : constant List_Id := New_List; - Default_Actuals : constant Elist_Id := New_Elmt_List; - Gen_Unit : constant Entity_Id := - Defining_Entity (Parent (F_Copy)); + Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; + Assoc : constant List_Id := New_List; + Default_Actuals : constant Elist_Id := New_Elmt_List; + Gen_Unit : constant Entity_Id := + Defining_Entity (Parent (F_Copy)); Actuals : List_Id; Actual : Node_Id; - Formal : Node_Id; - Next_Formal : Node_Id; Analyzed_Formal : Node_Id; + First_Named : Node_Id := Empty; + Formal : Node_Id; Match : Node_Id; Named : Node_Id; - First_Named : Node_Id := Empty; + Saved_Formal : Node_Id; Default_Formals : constant List_Id := New_List; -- If an Others_Choice is present, some of the formals may be defaulted. @@ -958,6 +958,10 @@ package body Sem_Ch12 is -- to formals of formal packages by AI05-0025, and it also applies to -- box-initialized formals. + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; + -- Determine whether the parameter types and the return type of Subp + -- are fully defined at the point of instantiation. + function Matching_Actual (F : Entity_Id; A_F : Entity_Id) return Node_Id; @@ -966,7 +970,7 @@ package body Sem_Ch12 is -- are named, scan the parameter associations to find the right one. -- A_F is the corresponding entity in the analyzed generic,which is -- placed on the selector name for ASIS use. - + -- -- In Ada 2005, a named association may be given with a box, in which -- case Matching_Actual sets Found_Assoc to the generic association, -- but return Empty for the actual itself. In this case the code below @@ -982,6 +986,10 @@ package body Sem_Ch12 is -- associations, and add an explicit box association for F if there -- is none yet, and the default comes from an Others_Choice. + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; + -- Determine whether Subp renames one of the subprograms defined in the + -- generated package Standard. + procedure Set_Analyzed_Formal; -- Find the node in the generic copy that corresponds to a given formal. -- The semantic information on this node is used to perform legality @@ -1025,6 +1033,62 @@ package body Sem_Ch12 is end loop; end Check_Overloaded_Formal_Subprogram; + ------------------------------- + -- Has_Fully_Defined_Profile -- + ------------------------------- + + function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; + -- Determine whethet type Typ is fully defined + + --------------------------- + -- Is_Fully_Defined_Type -- + --------------------------- + + function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is + begin + -- A private type without a full view is not fully defined + + if Is_Private_Type (Typ) + and then No (Full_View (Typ)) + then + return False; + + -- An incomplete type is never fully defined + + elsif Is_Incomplete_Type (Typ) then + return False; + + -- All other types are fully defined + + else + return True; + end if; + end Is_Fully_Defined_Type; + + -- Local declarations + + Param : Entity_Id; + + -- Start of processing for Has_Fully_Defined_Profile + + begin + -- Check the parameters + + Param := First_Formal (Subp); + while Present (Param) loop + if not Is_Fully_Defined_Type (Etype (Param)) then + return False; + end if; + + Next_Formal (Param); + end loop; + + -- Check the return type + + return Is_Fully_Defined_Type (Etype (Subp)); + end Has_Fully_Defined_Profile; + --------------------- -- Matching_Actual -- --------------------- @@ -1149,6 +1213,26 @@ package body Sem_Ch12 is end if; end Process_Default; + --------------------------------- + -- Renames_Standard_Subprogram -- + --------------------------------- + + function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is + Id : Entity_Id; + + begin + Id := Alias (Subp); + while Present (Id) loop + if Scope (Id) = Standard_Standard then + return True; + end if; + + Id := Alias (Id); + end loop; + + return False; + end Renames_Standard_Subprogram; + ------------------------- -- Set_Analyzed_Formal -- ------------------------- @@ -1259,7 +1343,7 @@ package body Sem_Ch12 is Named := First_Named; while Present (Named) loop if Nkind (Named) /= N_Others_Choice - and then No (Selector_Name (Named)) + and then No (Selector_Name (Named)) then Error_Msg_N ("invalid positional actual after named one", Named); Abandon_Instantiation (Named); @@ -1293,7 +1377,7 @@ package body Sem_Ch12 is while Present (Formal) loop Set_Analyzed_Formal; - Next_Formal := Next_Non_Pragma (Formal); + Saved_Formal := Next_Non_Pragma (Formal); case Nkind (Formal) is when N_Formal_Object_Declaration => @@ -1335,19 +1419,24 @@ package body Sem_Ch12 is Analyze (Match); Append_List (Instantiate_Type - (Formal, Match, Analyzed_Formal, Assoc), - Assoc); + (Formal, Match, Analyzed_Formal, Assoc), + Assoc); -- An instantiation is a freeze point for the actuals, -- unless this is a rewritten formal package, or the -- formal is an Ada 2012 formal incomplete type. - if Nkind (I_Node) /= N_Formal_Package_Declaration - and then - Ekind (Defining_Identifier (Analyzed_Formal)) /= - E_Incomplete_Type + if Nkind (I_Node) = N_Formal_Package_Declaration + or else + (Ada_Version >= Ada_2012 + and then + Ekind (Defining_Identifier (Analyzed_Formal)) = + E_Incomplete_Type) then - Append_Elmt (Entity (Match), Actual_Types); + null; + + else + Append_Elmt (Entity (Match), Actuals_To_Freeze); end if; end if; @@ -1364,9 +1453,9 @@ package body Sem_Ch12 is when N_Formal_Subprogram_Declaration => Match := - Matching_Actual ( - Defining_Unit_Name (Specification (Formal)), - Defining_Unit_Name (Specification (Analyzed_Formal))); + Matching_Actual + (Defining_Unit_Name (Specification (Formal)), + Defining_Unit_Name (Specification (Analyzed_Formal))); -- If the formal subprogram has the same name as another -- formal subprogram of the generic, then a named @@ -1384,10 +1473,9 @@ package body Sem_Ch12 is -- partial parametrization, or else the formal has a default -- or a box. - if No (Match) - and then Partial_Parametrization - then + if No (Match) and then Partial_Parametrization then Process_Default (Formal); + if Nkind (I_Node) = N_Formal_Package_Declaration then Check_Overloaded_Formal_Subprogram (Formal); end if; @@ -1396,6 +1484,37 @@ package body Sem_Ch12 is Append_To (Assoc, Instantiate_Formal_Subprogram (Formal, Match, Analyzed_Formal)); + + -- An instantiation is a freeze point for the actuals, + -- unless this is a rewritten formal package. + + if Nkind (I_Node) /= N_Formal_Package_Declaration + and then Nkind (Match) = N_Identifier + and then Is_Subprogram (Entity (Match)) + + -- The actual subprogram may rename a routine defined + -- in Standard. Avoid freezing such renamings because + -- subprograms coming from Standard cannot be frozen. + + and then + not Renames_Standard_Subprogram (Entity (Match)) + + -- If the actual subprogram comes from a different + -- unit, it is already frozen, either by a body in + -- that unit or by the end of the declarative part + -- of the unit. This check avoids the freezing of + -- subprograms defined in Standard which are used + -- as generic actuals. + + and then In_Same_Code_Unit (Entity (Match), I_Node) + and then Has_Fully_Defined_Profile (Entity (Match)) + then + -- Mark the subprogram as having a delayed freeze + -- since this may be an out-of-order action. + + Set_Has_Delayed_Freeze (Entity (Match)); + Append_Elmt (Entity (Match), Actuals_To_Freeze); + end if; end if; -- If this is a nested generic, preserve default for later @@ -1459,7 +1578,7 @@ package body Sem_Ch12 is end case; - Formal := Next_Formal; + Formal := Saved_Formal; Next_Non_Pragma (Analyzed_Formal); end loop; @@ -1484,8 +1603,12 @@ package body Sem_Ch12 is ("too many actuals in generic instantiation", Instantiation_Node); end if; + -- An instantiation freezes all generic actuals. The only exceptions + -- to this are incomplete types and subprograms which are not fully + -- defined at the point of instantiation. + declare - Elmt : Elmt_Id := First_Elmt (Actual_Types); + Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); begin while Present (Elmt) loop Freeze_Before (I_Node, Node (Elmt)); @@ -6818,11 +6941,6 @@ package body Sem_Ch12 is ------------- function Earlier (N1, N2 : Node_Id) return Boolean is - D1 : Integer := 0; - D2 : Integer := 0; - P1 : Node_Id := N1; - P2 : Node_Id := N2; - procedure Find_Depth (P : in out Node_Id; D : in out Integer); -- Find distance from given node to enclosing compilation unit @@ -6840,6 +6958,13 @@ package body Sem_Ch12 is end loop; end Find_Depth; + -- Local declarations + + D1 : Integer := 0; + D2 : Integer := 0; + P1 : Node_Id := N1; + P2 : Node_Id := N2; + -- Start of processing for Earlier begin @@ -6864,12 +6989,11 @@ package body Sem_Ch12 is end loop; -- At this point P1 and P2 are at the same distance from the root. - -- We examine their parents until we find a common declarative list, - -- at which point we can establish their relative placement by - -- comparing their ultimate slocs. If we reach the root, N1 and N2 - -- do not descend from the same declarative list (e.g. one is nested - -- in the declarative part and the other is in a block in the - -- statement part) and the earlier one is already frozen. + -- We examine their parents until we find a common declarative list. + -- If we reach the root, N1 and N2 do not descend from the same + -- declarative list (e.g. one is nested in the declarative part and + -- the other is in a block in the statement part) and the earlier + -- one is already frozen. while not Is_List_Member (P1) or else not Is_List_Member (P2) @@ -6891,22 +7015,99 @@ package body Sem_Ch12 is end if; end loop; - -- If the sloc positions are different the result is unambiguous. If - -- the slocs are identical, one of them must not come from source, which - -- is the case for freeze nodes, whose sloc is unrelated to the point - -- point at which they are inserted in the tree. The source node is the - -- earlier one in the tree. + -- Expanded code usually shares the source location of the original + -- construct it was generated for. This however may not necessarely + -- reflect the true location of the code within the tree. - if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then - return True; + -- Before comparing the slocs of the two nodes, make sure that we are + -- working with correct source locations. Assume that P1 is to the left + -- of P2. If either one does not come from source, traverse the common + -- list heading towards the other node and locate the first source + -- statement. - elsif - Top_Level_Location (Sloc (P1)) > Top_Level_Location (Sloc (P2)) - then - return False; + -- P1 P2 + -- ----+===+===+--------------+===+===+---- + -- expanded code expanded code + + if not Comes_From_Source (P1) then + while Present (P1) loop + + -- Neither P2 nor a source statement were located during the + -- search. If we reach the end of the list, then P1 does not + -- occur earlier than P2. + + -- ----> + -- start --- P2 ----- P1 --- end + + if No (Next (P1)) then + return False; + + -- We encounter P2 while going to the right of the list. This + -- means that P1 does indeed appear earlier. + -- ----> + -- start --- P1 ===== P2 --- end + -- expanded code in between + + elsif P1 = P2 then + return True; + + -- No need to look any further since we have located a source + -- statement. + + elsif Comes_From_Source (P1) then + exit; + end if; + + -- Keep going right + + Next (P1); + end loop; + end if; + + if not Comes_From_Source (P2) then + while Present (P2) loop + + -- Neither P1 nor a source statement were located during the + -- search. If we reach the start of the list, then P1 does not + -- occur earlier than P2. + + -- <---- + -- start --- P2 --- P1 --- end + + if No (Prev (P2)) then + return False; + + -- We encounter P1 while going to the left of the list. This + -- means that P1 does indeed appear earlier. + + -- <---- + -- start --- P1 ===== P2 --- end + -- expanded code in between + + elsif P2 = P1 then + return True; + + -- No need to look any further since we have located a source + -- statement. + + elsif Comes_From_Source (P2) then + exit; + end if; + + -- Keep going left + + Prev (P2); + end loop; + end if; + + -- At this point either both nodes came from source or we approximated + -- their source locations through neighbouring source statements. + + if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then + return True; else - return Comes_From_Source (P1); + return False; end if; end Earlier; -- 2.11.0