From 549cc9c2bcb93b5424c9a0967016d4e51e587311 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Nov 2015 12:52:59 +0100 Subject: [PATCH] [multiple changes] 2015-11-12 Ed Schonberg * sem_ch8.adb (Find_Selected_Component): In a synchronized body, a reference to an operation of an object of the same synchronized type was always interpreted as a reference to the current instance. This is not always the case, as the prefix of the reference may designate an object of the same type declared in the enclosing context prior to the body. 2015-11-12 Arnaud Charlet * impunit.ads, impunit.adb (Get_Kind_Of_File): New. Cleaned up implementation from previous Get_Kind_Of_Unit. (Get_Kind_Of_Unit): Reimplemented using Get_Kind_Of_File. * debug.adb: Remove d.4 switch, no longer used. * opt.ads: Update doc on Debugger_Level. * gnat1drv.adb: Code clean ups. * sinput.ads: minor fix in comment 2015-11-12 Bob Duff * sinfo.adb, sinfo.ads, sem_ch6.adb, atree.ads: Add Was_Expression_Function flag, which is set in sem_ch6.adb when converting an Expression_Function into a Subprogram_Body. 2015-11-12 Pascal Obry * usage.adb: Update overflow checking documentation. From-SVN: r230243 --- gcc/ada/ChangeLog | 29 +++++++++++++ gcc/ada/atree.ads | 2 +- gcc/ada/gnat1drv.adb | 10 +++-- gcc/ada/impunit.adb | 98 ++++++++++++++++++++------------------------ gcc/ada/impunit.ads | 7 +++- gcc/ada/opt.ads | 5 ++- gcc/ada/sem_ch6.adb | 1 + gcc/ada/sem_ch8.adb | 21 +++++++++- gcc/ada/sinfo.adb | 16 ++++++++ gcc/ada/sinfo.ads | 17 ++++++++ gcc/ada/sinput.ads | 2 +- gcc/ada/usage.adb | 5 ++- 12 files changed, 149 insertions(+), 64 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 52b839b7fc5..2931059cfe9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2015-11-12 Ed Schonberg + + * sem_ch8.adb (Find_Selected_Component): In a synchronized + body, a reference to an operation of an object of the same + synchronized type was always interpreted as a reference to the + current instance. This is not always the case, as the prefix of + the reference may designate an object of the same type declared + in the enclosing context prior to the body. + +2015-11-12 Arnaud Charlet + + * impunit.ads, impunit.adb (Get_Kind_Of_File): New. Cleaned up + implementation from previous Get_Kind_Of_Unit. + (Get_Kind_Of_Unit): Reimplemented using Get_Kind_Of_File. + * debug.adb: Remove d.4 switch, no longer used. + * opt.ads: Update doc on Debugger_Level. + * gnat1drv.adb: Code clean ups. + * sinput.ads: minor fix in comment + +2015-11-12 Bob Duff + + * sinfo.adb, sinfo.ads, sem_ch6.adb, atree.ads: Add + Was_Expression_Function flag, which is set in sem_ch6.adb when + converting an Expression_Function into a Subprogram_Body. + +2015-11-12 Pascal Obry + + * usage.adb: Update overflow checking documentation. + 2015-11-12 Tristan Gingold * snames.ads-tmpl: Name_Gnat_Extended_Ravenscar: New identifier. diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 56763c74d27..08ea27770c8 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -181,7 +181,7 @@ package Atree is -- Flag10 -- Flag11 Note that Flag0-3 are stored separately in the Flags -- Flag12 table, but that's a detail of the implementation which - -- Flag13 is entirely hidden by the funcitonal interface. + -- Flag13 is entirely hidden by the functional interface. -- Flag14 -- Flag15 -- Flag16 diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 586844d3a72..e84719a893e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -148,12 +148,16 @@ procedure Gnat1drv is Generate_C_Code := True; Modify_Tree_For_C := True; Unnest_Subprogram_Mode := True; - Back_Annotate_Rep_Info := True; -- Set operating mode to Generate_Code to benefit from full front-end -- expansion (e.g. generics). Operating_Mode := Generate_Code; + + -- Suppress alignment checks since we do not have access to alignment + -- info on the target + + Suppress_Options.Suppress (Alignment_Check) := False; end if; -- -gnatd.E sets Error_To_Warning mode, causing selected error messages @@ -1346,8 +1350,8 @@ begin Back_End.Call_Back_End (Back_End_Mode); -- Once the backend is complete, we unlock the names table. This call - -- allows a few extra entries, needed for example for the file name for - -- the library file output. + -- allows a few extra entries, needed for example for the file name + -- for the library file output. Namet.Unlock; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 6f6c9baee71..5fea99d59c9 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -635,23 +635,22 @@ package body Impunit is ("utf_32", Sutf_32'Access)); ---------------------- - -- Get_Kind_Of_Unit -- + -- Get_Kind_Of_File -- ---------------------- - function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit is - Fname : constant File_Name_Type := Unit_File_Name (U); + function Get_Kind_Of_File (File : String) return Kind_Of_Unit is + pragma Assert (File'First = 1); + + Buffer : String (1 .. 8); begin Error_Msg_Strlen := 0; - Get_Name_String (Fname); -- Ada/System/Interfaces are all Ada 95 units - if (Name_Len = 7 and then Name_Buffer (1 .. 7) = "ada.ads") - or else - (Name_Len = 10 and then Name_Buffer (1 .. 10) = "system.ads") - or else - (Name_Len = 12 and then Name_Buffer (1 .. 12) = "interfac.ads") + if File = "ada.ads" + or else File = "system.ads" + or else File = "interfac.ads" then return Ada_95_Unit; end if; @@ -659,21 +658,19 @@ package body Impunit is -- If length of file name is greater than 12, not predefined. The value -- 12 here is an 8 char name with extension .ads. - if Name_Len > 12 then + if File'Length > 12 then return Not_Predefined_Unit; end if; -- Not predefined if file name does not start with a- g- s- i- - if Name_Len < 3 - or else Name_Buffer (2) /= '-' - or else (Name_Buffer (1) /= 'a' - and then - Name_Buffer (1) /= 'g' - and then - Name_Buffer (1) /= 'i' - and then - Name_Buffer (1) /= 's') + if File'Length < 3 + or else File (2) /= '-' + or else + (File (1) /= 'a' + and then File (1) /= 'g' + and then File (1) /= 'i' + and then File (1) /= 's') then return Not_Predefined_Unit; end if; @@ -687,25 +684,25 @@ package body Impunit is -- this routine to detect when a construct comes from an instance of -- a generic defined in a predefined unit. - if Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" + if File (File'Last - 3 .. File'Last) /= ".ads" and then - Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb" + File (File'Last - 3 .. File'Last) /= ".adb" then return Not_Predefined_Unit; end if; -- Otherwise normalize file name to 8 characters - Name_Len := Name_Len - 4; - while Name_Len < 8 loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ' '; + Buffer (1 .. File'Length - 4) := File (1 .. File'Length - 4); + + for J in File'Length - 3 .. 8 loop + Buffer (J) := ' '; end loop; -- See if name is in 95 list for J in Non_Imp_File_Names_95'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then + if Buffer = Non_Imp_File_Names_95 (J).Fname then return Ada_95_Unit; end if; end loop; @@ -713,7 +710,7 @@ package body Impunit is -- See if name is in 2005 list for J in Non_Imp_File_Names_05'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then + if Buffer = Non_Imp_File_Names_05 (J).Fname then return Ada_2005_Unit; end if; end loop; @@ -721,7 +718,7 @@ package body Impunit is -- See if name is in 2012 list for J in Non_Imp_File_Names_12'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then + if Buffer = Non_Imp_File_Names_12 (J).Fname then return Ada_2012_Unit; end if; end loop; @@ -729,22 +726,9 @@ package body Impunit is -- Only remaining special possibilities are children of System.RPC and -- System.Garlic and special files of the form System.Aux... - Get_Name_String (Unit_Name (U)); - - if Name_Len > 12 - and then Name_Buffer (1 .. 11) = "system.rpc." - then - return Ada_95_Unit; - end if; - - if Name_Len > 15 - and then Name_Buffer (1 .. 14) = "system.garlic." - then - return Ada_95_Unit; - end if; - - if Name_Len > 11 - and then Name_Buffer (1 .. 10) = "system.aux" + if File (1 .. 5) = "s-rpc" + or else File (1 .. 5) = "s-gar" + or else File (1 .. 5) = "s-aux" then return Ada_95_Unit; end if; @@ -752,18 +736,16 @@ package body Impunit is -- All tests failed, this is definitely an implementation unit. See if -- we have an alternative name. - Get_Name_String (Fname); - - if Name_Len in 11 .. 12 - and then Name_Buffer (1 .. 2) = "s-" - and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" + if File'Length in 11 .. 12 + and then File (1 .. 2) = "s-" + and then File (File'Last - 3 .. File'Last) = ".ads" then for J in Map_Array'Range loop - if (Name_Len = 12 and then - Name_Buffer (3 .. 8) = Map_Array (J).Fname) + if (File'Length = 12 and then + File (3 .. 8) = Map_Array (J).Fname) or else - (Name_Len = 11 and then - Name_Buffer (3 .. 7) = Map_Array (J).Fname (1 .. 5)) + (File'Length = 11 and then + File (3 .. 7) = Map_Array (J).Fname (1 .. 5)) then Error_Msg_Strlen := Map_Array (J).Aname'Length; Error_Msg_String (1 .. Error_Msg_Strlen) := @@ -773,6 +755,16 @@ package body Impunit is end if; return Implementation_Unit; + end Get_Kind_Of_File; + + ---------------------- + -- Get_Kind_Of_Unit -- + ---------------------- + + function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit is + begin + Get_Name_String (Unit_File_Name (U)); + return Get_Kind_Of_File (Name_Buffer (1 .. Name_Len)); end Get_Kind_Of_Unit; ------------------- diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads index be3e8d3c06a..f4a11576848 100644 --- a/gcc/ada/impunit.ads +++ b/gcc/ada/impunit.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2015, 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- -- @@ -62,11 +62,14 @@ package Impunit is function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit; -- Given the unit number of a unit, this function determines the type -- of the unit, as defined above. If the result is Implementation_Unit, - -- then the name of a possible atlernative equivalent unit is placed in + -- then the name of a possible alternative equivalent unit is placed in -- Error_Msg_String/Slen on return. If there is no alternative name, or if -- the result is not Implementation_Unit, then Error_Msg_Slen is zero on -- return, indicating that no alternative name was found. + function Get_Kind_Of_File (File : String) return Kind_Of_Unit; + -- Same as Get_Kind_Of_Unit, for a given filename + function Is_Known_Unit (Nam : Node_Id) return Boolean; -- Nam is the possible name of a child unit, represented as a selected -- component node. This function determines whether the name matches one of diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index e99c6b71b25..60aeb28c9af 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -422,8 +422,9 @@ package Opt is subtype Debug_Level_Value is Nat range 0 .. 3; Debugger_Level : Debug_Level_Value := 0; -- The value given to the -g parameter. The default value for -g with - -- no value is 2. This is not currently used but is retained for possible - -- future use. + -- no value is 2. If no -g is specified, defaults to 0. + -- Note that the generated code should never depend on this variable, + -- since we want debug info to be non intrusive on the generate code. Default_Exit_Status : Int := 0; -- GNATBIND diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 91e41e259fa..a40baa59292 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -334,6 +334,7 @@ package body Sem_Ch6 is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (LocX, Statements => New_List (Ret))); + Set_Was_Expression_Function (New_Body); -- If the expression completes a generic subprogram, we must create a -- separate node for the body, because at instantiation the original diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d4487124e6b..9e581e0fa52 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6774,7 +6774,26 @@ package body Sem_Ch8 is -- Prefix denotes an enclosing loop, block, or task, i.e. an -- enclosing construct that is not a subprogram or accept. - Find_Expanded_Name (N); + -- A special case: a protected body may call an operation + -- on an external object of the same type, in which case it + -- is not an expanded name. If the prefix is the type itself, + -- or the context is a single synchronized object it can only + -- be interpreted as an expanded name. + + if Is_Concurrent_Type (Etype (P_Name)) then + if Is_Type (P_Name) + or else Present (Anonymous_Object (Etype (P_Name))) + then + Find_Expanded_Name (N); + + else + Analyze_Selected_Component (N); + return; + end if; + + else + Find_Expanded_Name (N); + end if; elsif Ekind (P_Name) = E_Package then Find_Expanded_Name (N); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 5f57e8c2f75..b97fa587657 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -3286,6 +3286,14 @@ package body Sinfo is return Elist5 (N); end Used_Operations; + function Was_Expression_Function + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + return Flag18 (N); + end Was_Expression_Function; + function Was_Originally_Stub (N : Node_Id) return Boolean is begin @@ -6525,6 +6533,14 @@ package body Sinfo is Set_Elist5 (N, Val); end Set_Used_Operations; + procedure Set_Was_Expression_Function + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag18 (N, Val); + end Set_Was_Expression_Function; + procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ab76d2c80ab..4b18de97f92 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2220,6 +2220,14 @@ package Sinfo is -- on exit from the scope of the use_type_clause, in particular in the -- case of Use_All_Type, when those operations several scopes. + -- Was_Expression_Function (Flag18-Sem) + -- Present in N_Subprogram_Body. True if the original source had an + -- N_Expression_Function, which was converted to the N_Subprogram_Body + -- by Analyze_Expression_Function. This is needed by ASIS to correctly + -- recreate the expression function (for the instance body) when the + -- completion of a generic function declaration is an expression + -- function. + -- Was_Originally_Stub (Flag13-Sem) -- This flag is set in the node for a proper body that replaces stub. -- During the analysis procedure, stubs in some situations get rewritten @@ -5212,6 +5220,7 @@ package Sinfo is -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- Was_Expression_Function (Flag18-Sem) ------------------------- -- Expression Function -- @@ -9795,6 +9804,9 @@ package Sinfo is function Used_Operations (N : Node_Id) return Elist_Id; -- Elist5 + function Was_Expression_Function + (N : Node_Id) return Boolean; -- Flag18 + function Was_Originally_Stub (N : Node_Id) return Boolean; -- Flag13 @@ -10830,6 +10842,9 @@ package Sinfo is procedure Set_Used_Operations (N : Node_Id; Val : Elist_Id); -- Elist5 + procedure Set_Was_Expression_Function + (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -12938,6 +12953,7 @@ package Sinfo is pragma Inline (Variants); pragma Inline (Visible_Declarations); pragma Inline (Used_Operations); + pragma Inline (Was_Expression_Function); pragma Inline (Was_Originally_Stub); pragma Inline (Withed_Body); @@ -13277,6 +13293,7 @@ package Sinfo is pragma Inline (Set_Variant_Part); pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); + pragma Inline (Set_Was_Expression_Function); pragma Inline (Set_Was_Originally_Stub); pragma Inline (Set_Withed_Body); diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 76ff65193e4..f1a27245afc 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -608,7 +608,7 @@ package Sinput is function Num_Source_Lines (S : Source_File_Index) return Nat; -- Returns the number of source lines (this is equivalent to reading -- the value of Last_Source_Line, but returns Nat rather than a - -- physical line number. + -- physical line number). procedure Register_Source_Ref_Pragma (File_Name : File_Name_Type; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index ae0981fd05c..99edf948928 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -360,8 +360,11 @@ begin -- Line for -gnato switch + Write_Switch_Char ("o0"); + Write_Line ("Disable overflow checking (on by default)"); + Write_Switch_Char ("o"); - Write_Line ("Enable overflow checking mode to CHECKED (off by default)"); + Write_Line ("Enable overflow checking in STRICT (-gnato1) mode (default)"); -- Lines for -gnato? switches