diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 105b9845fc2..c8f66355447 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,57 @@ +2012-10-01 Vincent Pucci + + * s-gearop.adb (Vector_Matrix_Product): Dimensions check fixed. Index + of Left in S evaluation fixed. + +2012-10-01 Javier Miranda + + * sem_ch3.adb (Analyze_Declarations): Avoid + premature freezing caused by the internally generated subprogram + _postconditions. + * checks.adb (Expr_Known_Valid): Float literals are assumed to be valid + in VM targets. + +2012-10-01 Thomas Quinot + + * sinput.ads, sinput.adb, sinput-l.adb sinput-c.adb (Sinput): New + Instances table, tracking all generic instantiations. Source file + attribute Instance replaces previous Instantiation attribute with an + index into the Instances table. + (Iterate_On_Instances): New generic procedure. + (Create_Instantiation_Source): Record instantiations in Instances. + (Tree_Read, Tree_Write): Read/write the instance table. + * scils.ads, scos.adb (SCO_Instance_Table): New table, contains + information copied from Sinput.Instance_Table, but self-contained + within the SCO data structures. + * par_sco.ads, par_sco.adb (To_Source_Location): Move to library level. + (Record_Instance): New subprogram, used by... + (Populate_SCO_Instance_Table): New subprogram to fill + the SCO instance table from the Sinput one (called by SCO_Output). + * opt.ads (Generate_SCO_Instance_Table): New option. + * put_scos.adb (Write_Instance_Table): New subprogram, used by... + (Put_SCOs): Dump the instance table at the end of SCO information + if requested. + * get_scos.adb (Get_SCOs): Read SCO_Instance_Table. + * types.h: Add declaration for Instance_Id. + * back_end.adb (Call_Back_End): Pass instance ids in source file + information table. + (Scan_Back_End_Switches): -fdebug-instances sets + Opt.Generate_SCO_Instance_Table. + * gcc-interface/gigi.h: File_Info_Type includes instance id. + * gcc-interface/trans.c: Under -fdebug-instances, set instance + id in line map from same in file info. + +2012-10-01 Thomas Quinot + + * sem_elab.adb: Minor reformatting + (Check_Elab_Call): Minor fix to debugging code + (add special circuit for the valid case where a 'Access attribute + reference is passed to Check_Elab_Call). + +2012-10-01 Thomas Quinot + + * exp_ch3.adb: Minor reformatting. + 2012-10-01 Ed Schonberg * exp_ch3.ads (Build_Array_Invariant_Proc): moved to body. diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index fa7c54d2f19..0cfd45fac30 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -76,6 +76,7 @@ package body Back_End is type File_Info_Type is record File_Name : File_Name_Type; + Instance : Instance_Id; Num_Source_Lines : Nat; end record; @@ -119,6 +120,7 @@ package body Back_End is for J in 1 .. Last_Source_File loop File_Info_Array (J).File_Name := Full_Debug_Name (J); + File_Info_Array (J).Instance := Instance (J); File_Info_Array (J).Num_Source_Lines := Nat (Physical_To_Logical (Last_Source_Line (J), J)); end loop; @@ -243,6 +245,12 @@ package body Back_End is elsif Switch_Chars (First .. Last) = "fdump-scos" then Opt.Generate_SCO := True; + -- Back end switch -fdebug-instances also enables instance table + -- SCO generation. + + elsif Switch_Chars (First .. Last) = "fdebug-instances" then + Opt.Generate_SCO_Instance_Table := True; + end if; end if; end Scan_Back_End_Switches; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 85f232b5efa..19a54d5658e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4599,6 +4599,13 @@ package body Checks is then return True; + -- Real literals are assumed to be valid in VM targets + + elsif VM_Target /= No_VM + and then Nkind (Expr) = N_Real_Literal + then + return True; + -- If we have a type conversion or a qualification of a known valid -- value, then the result will always be valid. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index dc7aa350c07..454348fa892 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -659,7 +659,7 @@ package body Exp_Ch3 is -- but it properly belongs with the array type declaration. However, if -- the freeze node is for a subtype of a type declared in another unit -- it seems preferable to use the freeze node as the source location of - -- of the init proc. In any case this is preferable for gcov usage, and + -- the init proc. In any case this is preferable for gcov usage, and -- the Sloc is not otherwise used by the compiler. if In_Open_Scopes (Scope (A_Type)) then diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 6edead04b6b..d4a81762f82 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -228,7 +228,8 @@ extern const char *ref_filename; struct File_Info_Type { File_Name_Type File_Name; - Nat Num_Source_Lines; + Instance_Id Instance; + Nat Num_Source_Lines; }; #ifdef __cplusplus diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 4d8dac90afc..661d9bfd778 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -293,6 +293,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, tree int64_type = gnat_type_for_size (64, 0); struct elab_info *info; int i; + struct line_map *map; max_gnat_nodes = max_gnat_node; @@ -325,7 +326,12 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, /* We create the line map for a source file at once, with a fixed number of columns chosen to avoid jumping over the next power of 2. */ - linemap_add (line_table, LC_ENTER, 0, filename, 1); + map = (struct line_map *) linemap_add + (line_table, LC_ENTER, 0, filename, 1); +#ifdef ORDINARY_MAP_INSTANCE + if (flag_debug_instances) + ORDINARY_MAP_INSTANCE(map) = file_info_ptr[i].Instance; +#endif linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); linemap_position_for_column (line_table, 252 - 1); linemap_add (line_table, LC_LEAVE, 0, NULL, 0); diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index ce662ce7e64..4fb00102929 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -225,7 +225,7 @@ begin case C is - -- Header entry + -- Header or instance table entry when ' ' => @@ -236,26 +236,71 @@ begin SCO_Table.Last; end if; - -- Scan out dependency number and file name - - Skip_Spaces; - Dnum := Get_Int; - Skip_Spaces; - N := 0; - while Nextc > ' ' loop - N := N + 1; - Buf (N) := Getc; - end loop; + case Nextc is - -- Make new unit table entry (will fill in To later) + -- Instance table entry - SCO_Unit_Table.Append ( - (File_Name => new String'(Buf (1 .. N)), - Dep_Num => Dnum, - From => SCO_Table.Last + 1, - To => 0)); + when 'i' => + declare + Inum : SCO_Instance_Index; + begin + Skipc; + Skip_Spaces; + + Inum := SCO_Instance_Index (Get_Int); + SCO_Instance_Table.Increment_Last; + pragma Assert (SCO_Instance_Table.Last = Inum); + + Skip_Spaces; + declare + SIE : SCO_Instance_Table_Entry + renames SCO_Instance_Table.Table (Inum); + begin + SIE.Inst_Dep_Num := Get_Int; + C := Getc; + pragma Assert (C = '|'); + Get_Source_Location (SIE.Inst_Loc); + + if not At_EOL then + Skip_Spaces; + SIE.Enclosing_Instance := + SCO_Instance_Index (Get_Int); + pragma Assert (SIE.Enclosing_Instance in + SCO_Instance_Table.First + .. SCO_Instance_Table.Last); + end if; + end; + end; + + -- Unit header + + when '0' .. '9' => + -- Scan out dependency number and file name + + Dnum := Get_Int; + + Skip_Spaces; + + N := 0; + while Nextc > ' ' loop + N := N + 1; + Buf (N) := Getc; + end loop; + + -- Make new unit table entry (will fill in To later) + + SCO_Unit_Table.Append ( + (File_Name => new String'(Buf (1 .. N)), + Dep_Num => Dnum, + From => SCO_Table.Last + 1, + To => 0)); + + when others => + raise Program_Error; + + end case; -- Statement entry diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index dc0d862c4dc..c90c5eca884 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -648,9 +648,14 @@ package Opt is Generate_SCO : Boolean := False; -- GNAT - -- True when switch -gnateS is used. When True, Source Coverage Obligation - -- (SCO) information is generated and output in the ALI file. See unit - -- Par_SCO for full details. + -- True when switch -fdump-scos (or -gnateS) is used. When True, Source + -- Coverage Obligation (SCO) information is generated and output in the ALI + -- file. See unit Par_SCO for full details. + + Generate_SCO_Instance_Table : Boolean := False; + -- GNAT + -- True when switch -fdebug-instances is used. When True, a table of + -- instances is included in SCOs. Generating_Code : Boolean := False; -- GNAT diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 78ff71bfd3b..29c03383218 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -102,6 +102,9 @@ package body Par_SCO is -- excluding OR and AND) and returns True if so, False otherwise, it does -- no other processing. + function To_Source_Location (S : Source_Ptr) return Source_Location; + -- Converts Source_Ptr value to Source_Location (line/col) format + procedure Process_Decisions (N : Node_Id; T : Character; @@ -138,6 +141,9 @@ package body Par_SCO is end record; No_Dominant : constant Dominant_Info := (' ', Empty); + procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr); + -- Add one entry from the instance table to the corresponding SCO table + procedure Traverse_Declarations_Or_Statements (L : List_Id; D : Dominant_Info := No_Dominant; @@ -696,16 +702,37 @@ package body Par_SCO is Debug_Put_SCOs; end pscos; + --------------------- + -- Record_Instance -- + --------------------- + + procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is + Inst_Src : constant Source_File_Index := + Get_Source_File_Index (Inst_Sloc); + begin + SCO_Instance_Table.Append + ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)), + Inst_Loc => To_Source_Location (Inst_Sloc), + Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src)))); + pragma Assert + (SCO_Instance_Table.Last = SCO_Instance_Index (Id)); + end Record_Instance; + ---------------- -- SCO_Output -- ---------------- procedure SCO_Output is + procedure Populate_SCO_Instance_Table is + new Sinput.Iterate_On_Instances (Record_Instance); + begin if Debug_Flag_Dot_OO then dsco; end if; + Populate_SCO_Instance_Table; + -- Sort the unit tables based on dependency numbers Unit_Table_Sort : declare @@ -949,26 +976,6 @@ package body Par_SCO is Pragma_Sloc : Source_Ptr := No_Location; Pragma_Name : Pragma_Id := Unknown_Pragma) is - function To_Source_Location (S : Source_Ptr) return Source_Location; - -- Converts Source_Ptr value to Source_Location (line/col) format - - ------------------------ - -- To_Source_Location -- - ------------------------ - - function To_Source_Location (S : Source_Ptr) return Source_Location is - begin - if S = No_Location then - return No_Source_Location; - else - return - (Line => Get_Logical_Line_Number (S), - Col => Get_Column_Number (S)); - end if; - end To_Source_Location; - - -- Start of processing for Set_Table_Entry - begin SCO_Table.Append ((C1 => C1, @@ -980,6 +987,21 @@ package body Par_SCO is Pragma_Name => Pragma_Name)); end Set_Table_Entry; + ------------------------ + -- To_Source_Location -- + ------------------------ + + function To_Source_Location (S : Source_Ptr) return Source_Location is + begin + if S = No_Location then + return No_Source_Location; + else + return + (Line => Get_Logical_Line_Number (S), + Col => Get_Column_Number (S)); + end if; + end To_Source_Location; + ----------------------------------------- -- Traverse_Declarations_Or_Statements -- ----------------------------------------- diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index a57f5c5b982..62a7467f647 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -61,9 +61,9 @@ package Par_SCO is -- True if Loc is the source location of a disabled pragma procedure SCO_Output; - -- Outputs SCO lines for all units, with appropriate section headers, for - -- unit U in the ALI file, as recorded by previous calls to SCO_Record, - -- possibly modified by calls to Set_SCO_Condition. + -- Outputs SCO lines for all units, with appropriate section headers, as + -- recorded by previous calls to SCO_Record, possibly modified by calls to + -- Set_SCO_Condition. procedure dsco; -- Debug routine to dump internal SCO table. This is a raw format dump diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 39fd04fcc7a..05184d7a985 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Opt; use Opt; with Par_SCO; use Par_SCO; with SCOs; use SCOs; with Snames; use Snames; @@ -34,6 +35,9 @@ procedure Put_SCOs is procedure Write_SCO_Initiate (SU : SCO_Unit_Index); -- Start SCO line for unit SU, also emitting SCO unit header if necessary + procedure Write_Instance_Table; + -- Output the SCO table of instances + procedure Output_Range (T : SCO_Table_Entry); -- Outputs T.From and T.To in line:col-line:col format @@ -76,6 +80,33 @@ procedure Put_SCOs is end loop; end Output_String; + -------------------------- + -- Write_Instance_Table -- + -------------------------- + + procedure Write_Instance_Table is + begin + for J in 1 .. SCO_Instance_Table.Last loop + declare + SIE : SCO_Instance_Table_Entry + renames SCO_Instance_Table.Table (J); + begin + Output_String ("C i "); + Write_Info_Nat (Nat (J)); + Write_Info_Char (' '); + Write_Info_Nat (SIE.Inst_Dep_Num); + Write_Info_Char ('|'); + Output_Source_Location (SIE.Inst_Loc); + + if SIE.Enclosing_Instance > 0 then + Write_Info_Char (' '); + Write_Info_Nat (Nat (SIE.Enclosing_Instance)); + end if; + Write_Info_Terminate; + end; + end loop; + end Write_Instance_Table; + ------------------------ -- Write_SCO_Initiate -- ------------------------ @@ -270,4 +301,8 @@ begin end loop; end; end loop; + + if Opt.Generate_SCO_Instance_Table then + Write_Instance_Table; + end if; end Put_SCOs; diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb index e1ce7e5d517..f84280ee8bb 100644 --- a/gcc/ada/s-gearop.adb +++ b/gcc/ada/s-gearop.adb @@ -902,7 +902,7 @@ package body System.Generic_Array_Operations is is begin return R : Result_Vector (Right'Range (2)) do - if Left'Length /= Right'Length (2) then + if Left'Length /= Right'Length (1) then raise Constraint_Error with "incompatible dimensions in vector-matrix multiplication"; end if; @@ -913,7 +913,7 @@ package body System.Generic_Array_Operations is begin for K in Right'Range (1) loop - S := S + Left (J - Right'First (1) + S := S + Left (K - Right'First (1) + Left'First) * Right (K, J); end loop; diff --git a/gcc/ada/scos.adb b/gcc/ada/scos.adb index b7df692de3a..fa8c66d6d0e 100644 --- a/gcc/ada/scos.adb +++ b/gcc/ada/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- -- @@ -33,6 +33,7 @@ package body SCOs is begin SCO_Table.Init; SCO_Unit_Table.Init; + SCO_Instance_Table.Init; -- Set dummy zeroth entry for sort routine, real entries start at 1 diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 9f478985284..d2d2c54982c 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -246,7 +246,7 @@ package SCOs is -- For each decision, a decision line is generated with the form: - -- C* sloc expression [chaining] + -- C* sloc expression -- Here * is one of the following characters: @@ -308,35 +308,6 @@ package SCOs is -- condition, and that is true even if the Ada 2005 set membership -- form is used, e.g. A in (2,7,11.15). - -- The expression can be followed by chaining indicators of the form - -- Tsloc-range or Fsloc-range, where the sloc-range is that of some - -- entry on a CS line. - - -- T* is present when the statement with the given sloc range is executed - -- if, and only if, the decision evaluates to TRUE. - - -- F* is present when the statement with the given sloc range is executed - -- if, and only if, the decision evaluates to FALSE. - - -- For an IF statement or ELSIF part, a T chaining indicator is always - -- present, with the sloc range of the first statement in the - -- corresponding sequence. - - -- For an ELSE part, the last decision in the IF statement (that of the - -- last ELSIF part, if any, or that of the IF statement if there is no - -- ELSIF part) has an F chaining indicator with the sloc range of the - -- first statement in the sequence of the ELSE part. - - -- For a WHILE loop, a T chaining indicator is always present, with the - -- sloc range of the first statement in the loop, but no F chaining - -- indicator is ever present. - - -- For an EXIT WHEN statement, an F chaining indicator is present if - -- there is an immediately following sequence in the same sequence of - -- statements. - - -- In all other cases, chaining indicators are omitted - -- Implementation permission: a SCO generator is permitted to emit a -- narrower SLOC range for a condition if the corresponding code -- generation circuitry ensures that all debug information for the code @@ -360,6 +331,19 @@ package SCOs is -- entries appear in one logical statement sequence, continuation lines -- are marked by Cc and appear immediately after the CC line. + -- Generic instances + + -- A table of all generic instantiations in the compilation is generated + -- whose entries have the form: + + -- C i index dependency-number|sloc [enclosing] + + -- Where index is the 1-based index of the entry in the table, + -- dependency-number and sloc indicate the source location of the + -- instantiation, and enclosing is the index of the enclosing + -- instantiation in the table (for a nested instantiation), or is + -- omitted for an outer instantiation. + -- Disabled pragmas -- No SCO is generated for disabled pragmas @@ -471,12 +455,6 @@ package SCOs is -- To = ending source location -- Last = False for all but the last entry, True for last entry - -- Element (chaining indicator) - -- C1 = 'H' (cHain) - -- C2 = 'T' or 'F' (chaining on decision true/false) - -- From = starting source location of chained statement - -- To = ending source location of chained statement - -- Note: the sequence starting with a decision, and continuing with -- operators and elements up to and including the first one labeled with -- Last = True, indicate the sequence to be output on one decision line. @@ -515,6 +493,27 @@ package SCOs is Table_Initial => 20, Table_Increment => 200); + ----------------------- + -- Generic instances -- + ----------------------- + + type SCO_Instance_Index is new Nat; + + type SCO_Instance_Table_Entry is record + Inst_Dep_Num : Nat; + Inst_Loc : Source_Location; + -- File and source location of instantiation + + Enclosing_Instance : SCO_Instance_Index; + end record; + + package SCO_Instance_Table is new GNAT.Table ( + Table_Component_Type => SCO_Instance_Table_Entry, + Table_Index_Type => SCO_Instance_Index, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 200); + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 483e7055f03..78ec8a0ba95 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2152,7 +2152,9 @@ package body Sem_Ch3 is -- explicitly checked that all required types are properly frozen, -- and we do not cause general freezing here. This special circuit -- is used when the encountered body is marked as having already - -- been analyzed. + -- been analyzed (although we must take into account the special + -- case of the internally generated subprogram _postconditions, + -- may not have been analyzed yet) -- In all other cases (bodies that come from source, and expander -- generated bodies that have not been analyzed yet), freeze all @@ -2168,6 +2170,11 @@ package body Sem_Ch3 is N_Task_Body) or else Nkind (Next_Node) in N_Body_Stub) + and then not + (Ada_Version = Ada_2012 + and then Nkind (Next_Node) = N_Subprogram_Body + and then Chars (Defining_Entity (Next_Node)) + = Name_uPostconditions) then Adjust_D; Freeze_All (Freeze_From, D); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index d1b5f7c6b55..e96d2317f28 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -153,7 +153,7 @@ package body Sem_Elab is -- This is set True till the compilation is complete, including the -- insertion of all instance bodies. Then when Check_Elab_Calls is called, -- the delay table is used to make the delayed calls and this flag is reset - -- to False, so that the calls are processed + -- to False, so that the calls are processed. ----------------------- -- Local Subprograms -- @@ -1162,8 +1162,6 @@ package body Sem_Elab is Ent : Entity_Id; P : Node_Id; - -- Start of processing for Check_Elab_Call - begin -- If the call does not come from the main unit, there is nothing to -- check. Elaboration call from units in the context of the main unit @@ -1206,10 +1204,17 @@ package body Sem_Elab is if Debug_Flag_LL then Write_Str (" Check_Elab_Call: "); - if No (Name (N)) - or else not Is_Entity_Name (Name (N)) - then + if Nkind (N) = N_Attribute_Reference then + if not Is_Entity_Name (Prefix (N)) then + Write_Str ("<>"); + else + Write_Name (Chars (Entity (Prefix (N)))); + end if; + Write_Str ("'Access"); + + elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then Write_Str ("<> "); + else Write_Name (Chars (Entity (Name (N)))); end if; diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index aebdcacdd12..4ad212b4314 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, 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- -- @@ -178,9 +178,10 @@ package body Sinput.C is Full_Debug_Name => Path_Id, Full_File_Name => Path_Id, Full_Ref_Name => Path_Id, + Instance => No_Instance_Id, Identifier_Casing => Unknown, + Inlined_Call => No_Location, Inlined_Body => False, - Instantiation => No_Location, Keyword_Casing => Unknown, Last_Source_Line => 1, License => Unknown, diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 52f3a713bb1..59d2aed4f99 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, 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- -- @@ -38,6 +38,8 @@ with Prep; use Prep; with Prepcomp; use Prepcomp; with Scans; use Scans; with Scn; use Scn; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with System; use System; @@ -138,127 +140,191 @@ package body Sinput.L is Source_File.Append (Source_File.Table (Xold)); Xnew := Source_File.Last; - Source_File.Table (Xnew).Inlined_Body := Inlined_Body; - Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node); - Source_File.Table (Xnew).Template := Xold; + declare + Sold : Source_File_Record renames Source_File.Table (Xold); + Snew : Source_File_Record renames Source_File.Table (Xnew); - -- Now we need to compute the new values of Source_First, Source_Last - -- and adjust the source file pointer to have the correct virtual - -- origin for the new range of values. + Inst_Spec : Node_Id; - Source_File.Table (Xnew).Source_First := - Source_File.Table (Xnew - 1).Source_Last + 1; - A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo; - Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust; + begin + Snew.Inlined_Body := Inlined_Body; + Snew.Template := Xold; - Set_Source_File_Index_Table (Xnew); + -- For a genuine generic instantiation, assign new instance id. + -- For inlined bodies, we retain that of the template, but we + -- save the call location. - Source_File.Table (Xnew).Sloc_Adjust := - Source_File.Table (Xold).Sloc_Adjust - A.Adjust; + if Inlined_Body then + Snew.Inlined_Call := Sloc (Inst_Node); - if Debug_Flag_L then - Write_Eol; - Write_Str ("*** Create instantiation source for "); + else - if Nkind (Dnod) in N_Proper_Body - and then Was_Originally_Stub (Dnod) - then - Write_Str ("subunit "); + -- If the spec has been instantiated already, and we are now + -- creating the instance source for the corresponding body now, + -- retrieve the instance id that was assigned to the spec, which + -- corresponds to the same instantiation sloc. + + Inst_Spec := Instance_Spec (Inst_Node); + if Present (Inst_Spec) then + declare + Inst_Spec_Ent : Entity_Id; + -- Instance spec entity + + Inst_Spec_Sloc : Source_Ptr; + -- Virtual sloc of the spec instance source + + Inst_Spec_Inst_Id : Instance_Id; + -- Instance id assigned to the instance spec + + begin + Inst_Spec_Ent := Defining_Entity (Inst_Spec); + + -- For a subprogram instantiation, we want the subprogram + -- instance, not the wrapper package. + + if Present (Related_Instance (Inst_Spec_Ent)) then + Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent); + end if; + + -- The specification of the instance entity has a virtual + -- sloc within the instance sloc range. + -- ??? But the Unit_Declaration_Node has the sloc of the + -- instantiation, which is somewhat of an oddity. + + Inst_Spec_Sloc := + Sloc (Specification (Unit_Declaration_Node + (Inst_Spec_Ent))); + Inst_Spec_Inst_Id := + Source_File.Table + (Get_Source_File_Index (Inst_Spec_Sloc)).Instance; + + pragma Assert + (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id)); + Snew.Instance := Inst_Spec_Inst_Id; + end; - elsif Ekind (Template_Id) = E_Generic_Package then - if Nkind (Dnod) = N_Package_Body then - Write_Str ("body of package "); else - Write_Str ("spec of package "); - end if; - - elsif Ekind (Template_Id) = E_Function then - Write_Str ("body of function "); - - elsif Ekind (Template_Id) = E_Procedure then - Write_Str ("body of procedure "); - - elsif Ekind (Template_Id) = E_Generic_Function then - Write_Str ("spec of function "); - - elsif Ekind (Template_Id) = E_Generic_Procedure then - Write_Str ("spec of procedure "); - - elsif Ekind (Template_Id) = E_Package_Body then - Write_Str ("body of package "); - - else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body); - - if Nkind (Dnod) = N_Procedure_Specification then - Write_Str ("body of procedure "); - else - Write_Str ("body of function "); + Instances.Append (Sloc (Inst_Node)); + Snew.Instance := Instances.Last; end if; end if; - Write_Name (Chars (Template_Id)); - Write_Eol; + -- Now we need to compute the new values of Source_First, + -- Source_Last and adjust the source file pointer to have the + -- correct virtual origin for the new range of values. - Write_Str (" new source index = "); - Write_Int (Int (Xnew)); - Write_Eol; + Snew.Source_First := Source_File.Table (Xnew - 1).Source_Last + 1; + A.Adjust := Snew.Source_First - A.Lo; + Snew.Source_Last := A.Hi + A.Adjust; - Write_Str (" copying from file name = "); - Write_Name (File_Name (Xold)); - Write_Eol; + Set_Source_File_Index_Table (Xnew); - Write_Str (" old source index = "); - Write_Int (Int (Xold)); - Write_Eol; + Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust; - Write_Str (" old lo = "); - Write_Int (Int (A.Lo)); - Write_Eol; + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Create instantiation source for "); - Write_Str (" old hi = "); - Write_Int (Int (A.Hi)); - Write_Eol; + if Nkind (Dnod) in N_Proper_Body + and then Was_Originally_Stub (Dnod) + then + Write_Str ("subunit "); - Write_Str (" new lo = "); - Write_Int (Int (Source_File.Table (Xnew).Source_First)); - Write_Eol; + elsif Ekind (Template_Id) = E_Generic_Package then + if Nkind (Dnod) = N_Package_Body then + Write_Str ("body of package "); + else + Write_Str ("spec of package "); + end if; - Write_Str (" new hi = "); - Write_Int (Int (Source_File.Table (Xnew).Source_Last)); - Write_Eol; + elsif Ekind (Template_Id) = E_Function then + Write_Str ("body of function "); - Write_Str (" adjustment factor = "); - Write_Int (Int (A.Adjust)); - Write_Eol; + elsif Ekind (Template_Id) = E_Procedure then + Write_Str ("body of procedure "); - Write_Str (" instantiation location: "); - Write_Location (Sloc (Inst_Node)); - Write_Eol; - end if; + elsif Ekind (Template_Id) = E_Generic_Function then + Write_Str ("spec of function "); - -- For a given character in the source, a higher subscript will be used - -- to access the instantiation, which means that the virtual origin must - -- have a corresponding lower value. We compute this new origin by - -- taking the address of the appropriate adjusted element in the old - -- array. Since this adjusted element will be at a negative subscript, - -- we must suppress checks. + elsif Ekind (Template_Id) = E_Generic_Procedure then + Write_Str ("spec of procedure "); - declare - pragma Suppress (All_Checks); + elsif Ekind (Template_Id) = E_Package_Body then + Write_Str ("body of package "); - pragma Warnings (Off); - -- This unchecked conversion is aliasing safe, since it is never used - -- to create improperly aliased pointer values. + else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body); - function To_Source_Buffer_Ptr is new - Unchecked_Conversion (Address, Source_Buffer_Ptr); + if Nkind (Dnod) = N_Procedure_Specification then + Write_Str ("body of procedure "); + else + Write_Str ("body of function "); + end if; + end if; - pragma Warnings (On); + Write_Name (Chars (Template_Id)); + Write_Eol; - begin - Source_File.Table (Xnew).Source_Text := - To_Source_Buffer_Ptr - (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address); + Write_Str (" new source index = "); + Write_Int (Int (Xnew)); + Write_Eol; + + Write_Str (" copying from file name = "); + Write_Name (File_Name (Xold)); + Write_Eol; + + Write_Str (" old source index = "); + Write_Int (Int (Xold)); + Write_Eol; + + Write_Str (" old lo = "); + Write_Int (Int (A.Lo)); + Write_Eol; + + Write_Str (" old hi = "); + Write_Int (Int (A.Hi)); + Write_Eol; + + Write_Str (" new lo = "); + Write_Int (Int (Snew.Source_First)); + Write_Eol; + + Write_Str (" new hi = "); + Write_Int (Int (Snew.Source_Last)); + Write_Eol; + + Write_Str (" adjustment factor = "); + Write_Int (Int (A.Adjust)); + Write_Eol; + + Write_Str (" instantiation location: "); + Write_Location (Sloc (Inst_Node)); + Write_Eol; + end if; + + -- For a given character in the source, a higher subscript will be + -- used to access the instantiation, which means that the virtual + -- origin must have a corresponding lower value. We compute this new + -- origin by taking the address of the appropriate adjusted element + -- in the old array. Since this adjusted element will be at a + -- negative subscript, we must suppress checks. + + declare + pragma Suppress (All_Checks); + + pragma Warnings (Off); + -- This unchecked conversion is aliasing safe, since it is never + -- used to create improperly aliased pointer values. + + function To_Source_Buffer_Ptr is new + Unchecked_Conversion (Address, Source_Buffer_Ptr); + + pragma Warnings (On); + + begin + Snew.Source_Text := + To_Source_Buffer_Ptr + (Sold.Source_Text (-A.Adjust)'Address); + end; end; end Create_Instantiation_Source; @@ -433,9 +499,10 @@ package body Sinput.L is Full_Debug_Name => Osint.Full_Source_Name, Full_File_Name => Osint.Full_Source_Name, Full_Ref_Name => Osint.Full_Source_Name, + Instance => No_Instance_Id, Identifier_Casing => Unknown, + Inlined_Call => No_Location, Inlined_Body => False, - Instantiation => No_Location, Keyword_Casing => Unknown, Last_Source_Line => 1, License => Unknown, diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 5e1ac44b617..29be59ac688 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -477,8 +477,26 @@ package body Sinput is First_Time_Around := True; Source_File.Init; + + Instances.Init; + Instances.Append (No_Location); + pragma Assert (Instances.Last = No_Instance_Id); end Initialize; + ------------------- + -- Instantiation -- + ------------------- + + function Instantiation (S : SFI) return Source_Ptr is + SIE : Source_File_Record renames Source_File.Table (S); + begin + if SIE.Inlined_Body then + return SIE.Inlined_Call; + else + return Instances.Table (SIE.Instance); + end if; + end Instantiation; + ------------------------- -- Instantiation_Depth -- ------------------------- @@ -511,6 +529,17 @@ package body Sinput is return Instantiation (Get_Source_File_Index (S)); end Instantiation_Location; + -------------------------- + -- Iterate_On_Instances -- + -------------------------- + + procedure Iterate_On_Instances is + begin + for J in 1 .. Instances.Last loop + Process (J, Instances.Table (J)); + end loop; + end Iterate_On_Instances; + ---------------------- -- Last_Source_File -- ---------------------- @@ -852,7 +881,7 @@ package body Sinput is Tmp1 : Source_Buffer_Ptr; begin - if S.Instantiation /= No_Location then + if S.Instance /= No_Instance_Id then null; else @@ -887,9 +916,10 @@ package body Sinput is Source_Cache_First := 1; Source_Cache_Last := 0; - -- Read in source file table + -- Read in source file table and instance table Source_File.Tree_Read; + Instances.Tree_Read; -- The pointers we read in there for the source buffer and lines -- table pointers are junk. We now read in the actual data that @@ -904,7 +934,7 @@ package body Sinput is -- we share the data for the generic template entry. Since the -- template always occurs first, we can safely refer to its data. - if S.Instantiation /= No_Location then + if S.Instance /= No_Instance_Id then declare ST : Source_File_Record renames Source_File.Table (S.Template); @@ -1004,6 +1034,7 @@ package body Sinput is procedure Tree_Write is begin Source_File.Tree_Write; + Instances.Tree_Write; -- The pointers we wrote out there for the source buffer and lines -- table pointers are junk, we now write out the actual data that @@ -1018,7 +1049,7 @@ package body Sinput is -- shared with the generic template. When the tree is read, the -- pointers must be set, but no extra data needs to be written. - if S.Instantiation /= No_Location then + if S.Instance /= No_Instance_Id then null; -- For the normal case, write out the data of the tables @@ -1131,6 +1162,11 @@ package body Sinput is return Source_File.Table (S).Debug_Source_Name; end Debug_Source_Name; + function Instance (S : SFI) return Instance_Id is + begin + return Source_File.Table (S).Instance; + end Instance; + function File_Name (S : SFI) return File_Name_Type is begin return Source_File.Table (S).File_Name; @@ -1171,10 +1207,10 @@ package body Sinput is return Source_File.Table (S).Inlined_Body; end Inlined_Body; - function Instantiation (S : SFI) return Source_Ptr is + function Inlined_Call (S : SFI) return Source_Ptr is begin - return Source_File.Table (S).Instantiation; - end Instantiation; + return Source_File.Table (S).Inlined_Call; + end Inlined_Call; function Keyword_Casing (S : SFI) return Casing_Type is begin diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 32aab9d3966..f678ff62984 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -83,6 +83,9 @@ package Sinput is Preproc); -- Source file with preprocessing commands to be preprocessed + type Instance_Id is new Nat; + No_Instance_Id : constant Instance_Id; + ---------------------------- -- Source License Control -- ---------------------------- @@ -198,6 +201,12 @@ package Sinput is -- Only processing in Sprint that generates this file is permitted to -- set this field. + -- Instance : Instance_Id (read-only) + -- For entries corresponding to a generic instantiation, unique + -- identifier denoting the full chain of nested instantiations. Set to + -- No_Instance_Id for the case of a normal, non-instantiation entry. + -- See below for details on the handling of generic instantiations. + -- License : License_Type; -- License status of source file @@ -249,16 +258,16 @@ package Sinput is -- This value is used for formatting of error messages, and also is used -- in the detection of keywords misused as identifiers. - -- Instantiation : Source_Ptr; - -- Source file location of the instantiation if this source file entry - -- represents a generic instantiation. Set to No_Location for the case - -- of a normal non-instantiation entry. See section below for details. + -- Inlined_Call : Source_Ptr; + -- Source file location of the subprogram call if this source file entry + -- represents an inlined body. Set to No_Location otherwise. -- This field is read-only for clients. -- Inlined_Body : Boolean; -- This can only be set True if Instantiation has a value other than -- No_Location. If true it indicates that the instantiation is actually -- an instance of an inlined body. + -- ??? Redundant, always equal to (Inlined_Call /= No_Location) -- Template : Source_File_Index; (read-only) -- Source file index of the source file containing the template if this @@ -289,7 +298,8 @@ package Sinput is function Full_Ref_Name (S : SFI) return File_Name_Type; function Identifier_Casing (S : SFI) return Casing_Type; function Inlined_Body (S : SFI) return Boolean; - function Instantiation (S : SFI) return Source_Ptr; + function Inlined_Call (S : SFI) return Source_Ptr; + function Instance (S : SFI) return Instance_Id; function Keyword_Casing (S : SFI) return Casing_Type; function Last_Source_Line (S : SFI) return Physical_Line_Number; function License (S : SFI) return License_Type; @@ -408,17 +418,31 @@ package Sinput is -- to point to the same text, because of the virtual origin pointers used -- in the source table. - -- The Instantiation field of this source file index entry, usually set - -- to No_Source_File, instead contains the Sloc of the instantiation. In - -- the case of nested instantiations, this Sloc may itself refer to an - -- instantiation, so the complete chain can be traced. + -- The Instantiation_Id field of this source file index entry, set + -- to No_Instance_Id for normal entries, instead contains a value that + -- uniquely identifies a particular instantiation, and the associated + -- entry in the Instances table. The source location of the instantiation + -- can be retrieved using function Instantiation below. In the case of + -- nested instantiations, the Instances table can be used to trace the + -- complete chain of nested instantiations. - -- Two routines are used to build these special entries in the source - -- file table. Create_Instantiation_Source is first called to build + -- Two routines are used to build the special instance entries in the + -- source file table. Create_Instantiation_Source is first called to build -- the virtual source table entry for the instantiation, and then the -- Sloc values in the copy are adjusted using Adjust_Instantiation_Sloc. -- See child unit Sinput.L for details on these two routines. + generic + with procedure Process (Id : Instance_Id; Inst_Sloc : Source_Ptr); + procedure Iterate_On_Instances; + -- Execute Process for each entry in the instance table + + function Instantiation (S : SFI) return Source_Ptr; + -- For a source file entry that represents an inlined body, source location + -- of the inlined call. Otherwise, for a source file entry that represents + -- a generic instantiation, source location of the instantiation. Returns + -- No_Location in all other cases. + ----------------- -- Global Data -- ----------------- @@ -722,25 +746,37 @@ package Sinput is private pragma Inline (File_Name); - pragma Inline (First_Mapped_Line); pragma Inline (Full_File_Name); - pragma Inline (Identifier_Casing); - pragma Inline (Instantiation); - pragma Inline (Keyword_Casing); - pragma Inline (Last_Source_Line); - pragma Inline (Last_Source_File); + pragma Inline (File_Type); + pragma Inline (Reference_Name); + pragma Inline (Full_Ref_Name); + pragma Inline (Debug_Source_Name); + pragma Inline (Full_Debug_Name); + pragma Inline (Instance); pragma Inline (License); pragma Inline (Num_SRef_Pragmas); - pragma Inline (Num_Source_Files); - pragma Inline (Num_Source_Lines); - pragma Inline (Reference_Name); - pragma Inline (Set_Keyword_Casing); - pragma Inline (Set_Identifier_Casing); + pragma Inline (First_Mapped_Line); + pragma Inline (Source_Text); pragma Inline (Source_First); pragma Inline (Source_Last); - pragma Inline (Source_Text); - pragma Inline (Template); pragma Inline (Time_Stamp); + pragma Inline (Source_Checksum); + pragma Inline (Last_Source_Line); + pragma Inline (Keyword_Casing); + pragma Inline (Identifier_Casing); + pragma Inline (Inlined_Call); + pragma Inline (Inlined_Body); + pragma Inline (Template); + pragma Inline (Unit); + + pragma Inline (Set_Keyword_Casing); + pragma Inline (Set_Identifier_Casing); + + pragma Inline (Last_Source_File); + pragma Inline (Num_Source_Files); + pragma Inline (Num_Source_Lines); + + No_Instance_Id : constant Instance_Id := 0; ------------------------- -- Source_Lines Tables -- @@ -781,6 +817,7 @@ private Full_Debug_Name : File_Name_Type; Full_File_Name : File_Name_Type; Full_Ref_Name : File_Name_Type; + Instance : Instance_Id; Num_SRef_Pragmas : Nat; First_Mapped_Line : Logical_Line_Number; Source_Text : Source_Buffer_Ptr; @@ -788,11 +825,11 @@ private Source_Last : Source_Ptr; Source_Checksum : Word; Last_Source_Line : Physical_Line_Number; - Instantiation : Source_Ptr; Template : Source_File_Index; Unit : Unit_Number_Type; Time_Stamp : Time_Stamp_Type; File_Type : Type_Of_File; + Inlined_Call : Source_Ptr; Inlined_Body : Boolean; License : License_Type; Keyword_Casing : Casing_Type; @@ -839,17 +876,18 @@ private Full_Debug_Name at 12 range 0 .. 31; Full_File_Name at 16 range 0 .. 31; Full_Ref_Name at 20 range 0 .. 31; + Instance at 48 range 0 .. 31; Num_SRef_Pragmas at 24 range 0 .. 31; First_Mapped_Line at 28 range 0 .. 31; Source_First at 32 range 0 .. 31; Source_Last at 36 range 0 .. 31; Source_Checksum at 40 range 0 .. 31; Last_Source_Line at 44 range 0 .. 31; - Instantiation at 48 range 0 .. 31; Template at 52 range 0 .. 31; Unit at 56 range 0 .. 31; Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1; File_Type at 74 range 0 .. 7; + Inlined_Call at 88 range 0 .. 31; Inlined_Body at 75 range 0 .. 7; License at 76 range 0 .. 7; Keyword_Casing at 77 range 0 .. 7; @@ -860,12 +898,12 @@ private -- The following fields are pointers, so we have to specialize their -- lengths using pointer size, obtained above as Standard'Address_Size. - Source_Text at 88 range 0 .. AS - 1; - Lines_Table at 88 range AS .. AS * 2 - 1; - Logical_Lines_Table at 88 range AS * 2 .. AS * 3 - 1; + Source_Text at 92 range 0 .. AS - 1; + Lines_Table at 92 range AS .. AS * 2 - 1; + Logical_Lines_Table at 92 range AS * 2 .. AS * 3 - 1; end record; - for Source_File_Record'Size use 88 * 8 + AS * 3; + for Source_File_Record'Size use 92 * 8 + AS * 3; -- This ensures that we did not leave out any fields package Source_File is new Table.Table ( @@ -876,6 +914,17 @@ private Table_Increment => Alloc.Source_File_Increment, Table_Name => "Source_File"); + -- Auxiliary table containing source location of instantiations. Index 0 + -- is used for code that does not come from an instance. + + package Instances is new Table.Table ( + Table_Component_Type => Source_Ptr, + Table_Index_Type => Instance_Id, + Table_Low_Bound => 0, + Table_Initial => Alloc.Source_File_Initial, + Table_Increment => Alloc.Source_File_Increment, + Table_Name => "Instances"); + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 4e29447f826..a0f28910d11 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * 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- * @@ -130,6 +130,9 @@ typedef Text_Ptr Source_Ptr; /* Used for Sloc in all nodes in the representation of package Standard. */ #define Standard_Location -2 +/* Instance identifiers */ +typedef Nat Instance_Id; + /* Type used for union of all possible ID values covering all ranges */ typedef int Union_Id;