From 66f95f60458a1da2e82c4b879357ebe36fcdb879 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 13:56:31 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Eric Botcazou * sem_ch7.adb: Update comment. 2017-09-06 Yannick Moy * einfo.adb, einfo.ads (Is_Subprogram_Or_Entry): New predicate. * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Use new function. * sem_util.adb, sem_util.ads (Within_Protected_Type): Renaming with slight modification from Is_Subp_Or_Entry_Inside_Protected, so that applies to any entity. 2017-09-06 Yannick Moy * sem_ch3.adb (Derived_Type_Declaration): Use Incomplete_Or_Partial_View rather than local Find_Partial_View. 2017-09-06 Javier Miranda * g-catiio.ads, g-catiio.adb (Value): Extended to parse an UTC time following ISO-8861. 2017-09-06 Ed Schonberg * sem_dim.adb (Analyze_Dimension): In an instance, a type conversion takes its dimensions from the expression, not from the context type. (Dimensions_Of_Operand): Ditto. 2017-09-06 Ed Schonberg * exp_ch6.adb (Expand_Call_Helper): Do not optimize calls to null procedures when GNAT coverage is used, so that their (empty) bodies are properly covered. 2017-09-06 Bob Duff * sem_ch13.adb (Resolve_Aspect_Expressions): If the entity is a type with discriminants, make the discriminants directly visible in aspect clauses. 2017-09-06 Ed Schonberg * sem_res.adb (Resolve_Arithmentic_Op): If both operands are Universal_Real and the context is a floating-point type, resolve both operands to the target type. From-SVN: r251783 --- gcc/ada/ChangeLog | 47 +++++ gcc/ada/einfo.adb | 7 + gcc/ada/einfo.ads | 1 + gcc/ada/exp_ch6.adb | 5 +- gcc/ada/g-catiio.adb | 419 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/g-catiio.ads | 14 +- gcc/ada/inline.adb | 139 +++++++------- gcc/ada/sem_ch13.adb | 135 +++++++------- gcc/ada/sem_ch3.adb | 36 +--- gcc/ada/sem_ch7.adb | 9 +- gcc/ada/sem_dim.adb | 28 ++- gcc/ada/sem_res.adb | 7 + gcc/ada/sem_util.adb | 46 ++--- gcc/ada/sem_util.ads | 7 +- 14 files changed, 694 insertions(+), 206 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0f142f5fe12..fd11670e146 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2017-09-06 Eric Botcazou + + * sem_ch7.adb: Update comment. + +2017-09-06 Yannick Moy + + * einfo.adb, einfo.ads (Is_Subprogram_Or_Entry): New predicate. + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Use new function. + * sem_util.adb, sem_util.ads (Within_Protected_Type): Renaming + with slight modification from Is_Subp_Or_Entry_Inside_Protected, + so that applies to any entity. + +2017-09-06 Yannick Moy + + * sem_ch3.adb (Derived_Type_Declaration): Use + Incomplete_Or_Partial_View rather than local Find_Partial_View. + +2017-09-06 Javier Miranda + + * g-catiio.ads, g-catiio.adb (Value): Extended to parse an UTC time + following ISO-8861. + +2017-09-06 Ed Schonberg + + * sem_dim.adb (Analyze_Dimension): In an instance, a type + conversion takes its dimensions from the expression, not from + the context type. + (Dimensions_Of_Operand): Ditto. + +2017-09-06 Ed Schonberg + + * exp_ch6.adb (Expand_Call_Helper): Do not optimize calls to + null procedures when GNAT coverage is used, so that their (empty) + bodies are properly covered. + +2017-09-06 Bob Duff + + * sem_ch13.adb (Resolve_Aspect_Expressions): If + the entity is a type with discriminants, make the discriminants + directly visible in aspect clauses. + +2017-09-06 Ed Schonberg + + * sem_res.adb (Resolve_Arithmentic_Op): If both operands are + Universal_Real and the context is a floating-point type, resolve + both operands to the target type. + 2017-09-06 Hristian Kirtchev * a-comlin.adb, exp_aggr.adb, exp_ch6.adb, frontend.adb, gnatbind.adb, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 4c9f5747e80..6d9ae1da7fe 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3764,6 +3764,13 @@ package body Einfo is return Ekind (Id) in Subprogram_Kind; end Is_Subprogram; + function Is_Subprogram_Or_Entry (Id : E) return B is + begin + return Ekind (Id) in Subprogram_Kind + or else + Ekind (Id) in Entry_Kind; + end Is_Subprogram_Or_Entry; + function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is begin return Ekind (Id) in Subprogram_Kind diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7826d42093c..cf472ee53e9 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -7445,6 +7445,7 @@ package Einfo is function Is_Scalar_Type (Id : E) return B; function Is_Signed_Integer_Type (Id : E) return B; function Is_Subprogram (Id : E) return B; + function Is_Subprogram_Or_Entry (Id : E) return B; function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B; function Is_Task_Type (Id : E) return B; function Is_Type (Id : E) return B; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0a219f5c10f..58ced4760ef 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3955,8 +3955,11 @@ package body Exp_Ch6 is -- A call to a null procedure is replaced by a null statement, but we -- are not allowed to ignore possible side effects of the call, so we -- make sure that actuals are evaluated. + -- We also suppress this optimization for GNATCoverage. - elsif Is_Null_Procedure (Subp) then + elsif Is_Null_Procedure (Subp) + and then not Opt.Suppress_Control_Flow_Optimizations + then Actual := First_Actual (Call_Node); while Present (Actual) loop Remove_Side_Effects (Actual); diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb index 772a70b8839..17ce098ab9e 100644 --- a/gcc/ada/g-catiio.adb +++ b/gcc/ada/g-catiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2016, AdaCore -- +-- Copyright (C) 1999-2017, 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- -- @@ -93,6 +93,26 @@ package body GNAT.Calendar.Time_IO is Length : Natural := 0) return String; -- As above with N provided in Integer format + procedure Parse_ISO_8861_UTC + (Date : String; + Time : out Ada.Calendar.Time; + Success : out Boolean); + -- Subsidiary of function Value. It parses the string Date, interpreted as + -- an ISO 8861 time representation, and returns corresponding Time value. + -- Success is set to False when the string is not a supported ISO 8861 + -- date. The following regular expression defines the supported format: + -- + -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) + -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] + -- + -- Trailing characters (in particular spaces) are not allowed. + -- + -- Examples: + -- + -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 + -- 2017-04-14T14:47:06,12 20170414T14:47:06.12 + -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 + ----------- -- Am_Pm -- ----------- @@ -531,7 +551,7 @@ package body GNAT.Calendar.Time_IO is "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); -- Short version of the month names, used when parsing date strings - S : String := Str; + S : String := Str; begin GNAT.Case_Util.To_Upper (S); @@ -545,6 +565,390 @@ package body GNAT.Calendar.Time_IO is return Abbrev_Upper_Month_Names'First; end Month_Name_To_Number; + ------------------------ + -- Parse_ISO_8861_UTC -- + ------------------------ + + procedure Parse_ISO_8861_UTC + (Date : String; + Time : out Ada.Calendar.Time; + Success : out Boolean) + is + Index : Positive := Date'First; + -- The current character scan index. After a call to Advance, Index + -- points to the next character. + + End_Of_Source_Reached : exception; + -- An exception used to signal that the scan pointer has reached the + -- end of the source string. + + Wrong_Syntax : exception; + -- An exception used to signal that the scan pointer has reached an + -- unexpected character in the source string. + + procedure Advance; + pragma Inline (Advance); + -- Past the current character of Date + + procedure Advance_Digits (Num_Digits : Positive); + pragma Inline (Advance_Digits); + -- Past the given number of digit characters + + function Scan_Day return Day_Number; + pragma Inline (Scan_Day); + -- Scan the two digits of a day number and return its value + + function Scan_Hour return Hour_Number; + pragma Inline (Scan_Hour); + -- Scan the two digits of an hour number and return its value + + function Scan_Minute return Minute_Number; + pragma Inline (Scan_Minute); + -- Scan the two digits of a minute number and return its value + + function Scan_Month return Month_Number; + pragma Inline (Scan_Month); + -- Scan the two digits of a month number and return its value + + function Scan_Second return Second_Number; + pragma Inline (Scan_Second); + -- Scan the two digits of a second number and return its value + + function Scan_Separator (Expected_Symbol : Character) return Boolean; + pragma Inline (Scan_Separator); + -- If the current symbol matches the Expected_Symbol then advance the + -- scanner index and return True; otherwise do nothing and return False + + procedure Scan_Separator (Required : Boolean; Separator : Character); + pragma Inline (Scan_Separator); + -- If Required then check that the current character matches Separator + -- and advance the scanner index; if not Required then do nothing. + + function Scan_Subsecond return Second_Duration; + pragma Inline (Scan_Subsecond); + -- Scan all the digits of a subsecond number and return its value + + function Scan_Year return Year_Number; + pragma Inline (Scan_Year); + -- Scan the four digits of a year number and return its value + + function Symbol return Character; + pragma Inline (Symbol); + -- Return the current character being scanned + + ------------- + -- Advance -- + ------------- + + procedure Advance is + begin + -- Signal the end of the source string. This stops a complex scan by + -- bottoming up any recursive calls till control reaches routine Scan + -- which handles the exception. Certain scanning scenarios may handle + -- this exception on their own. + + if Index > Date'Last then + raise End_Of_Source_Reached; + + -- Advance the scan pointer as long as there are characters to scan, + -- in other words, the scan pointer has not passed the end of the + -- source string. + + else + Index := Index + 1; + end if; + end Advance; + + -------------------- + -- Advance_Digits -- + -------------------- + + procedure Advance_Digits (Num_Digits : Positive) is + begin + for J in 1 .. Num_Digits loop + if Symbol not in '0' .. '9' then + raise Wrong_Syntax; + end if; + + Advance; -- past digit + end loop; + end Advance_Digits; + + -------------- + -- Scan_Day -- + -------------- + + function Scan_Day return Day_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Day_Number'Value (Date (From .. Index - 1)); + end Scan_Day; + + --------------- + -- Scan_Hour -- + --------------- + + function Scan_Hour return Hour_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Hour_Number'Value (Date (From .. Index - 1)); + end Scan_Hour; + + ----------------- + -- Scan_Minute -- + ----------------- + + function Scan_Minute return Minute_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Minute_Number'Value (Date (From .. Index - 1)); + end Scan_Minute; + + ---------------- + -- Scan_Month -- + ---------------- + + function Scan_Month return Month_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Month_Number'Value (Date (From .. Index - 1)); + end Scan_Month; + + ----------------- + -- Scan_Second -- + ----------------- + + function Scan_Second return Second_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Second_Number'Value (Date (From .. Index - 1)); + end Scan_Second; + + -------------------- + -- Scan_Separator -- + -------------------- + + function Scan_Separator (Expected_Symbol : Character) return Boolean is + begin + if Symbol = Expected_Symbol then + Advance; + return True; + else + return False; + end if; + end Scan_Separator; + + -------------------- + -- Scan_Separator -- + -------------------- + + procedure Scan_Separator (Required : Boolean; Separator : Character) is + begin + if Required then + if Symbol /= Separator then + raise Wrong_Syntax; + end if; + + Advance; -- Past the separator + end if; + end Scan_Separator; + + -------------------- + -- Scan_Subsecond -- + -------------------- + + function Scan_Subsecond return Second_Duration is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 1); + + while Symbol in '0' .. '9' + and then Index < Date'Length + loop + Advance; + end loop; + + if Symbol not in '0' .. '9' then + raise Wrong_Syntax; + end if; + + Advance; + return Second_Duration'Value ("0." & Date (From .. Index - 1)); + end Scan_Subsecond; + + --------------- + -- Scan_Year -- + --------------- + + function Scan_Year return Year_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 4); + return Year_Number'Value (Date (From .. Index - 1)); + end Scan_Year; + + ------------ + -- Symbol -- + ------------ + + function Symbol return Character is + begin + -- Signal the end of the source string. This stops a complex scan by + -- bottoming up any recursive calls till control reaches routine Scan + -- which handles the exception. Certain scanning scenarios may handle + -- this exception on their own. + + if Index > Date'Last then + raise End_Of_Source_Reached; + + else + return Date (Index); + end if; + end Symbol; + + -- Local variables + + Date_Separator : constant Character := '-'; + Hour_Separator : constant Character := ':'; + Day : Day_Number; + Month : Month_Number; + Year : Year_Number; + Hour : Hour_Number := 0; + Minute : Minute_Number := 0; + Second : Second_Number := 0; + Subsec : Second_Duration := 0.0; + + Local_Hour : Hour_Number := 0; + Local_Minute : Minute_Number := 0; + Local_Sign : Character := ' '; + Local_Disp : Duration; + + Sep_Required : Boolean := False; + -- True if a separator is seen (and therefore required after it!) + + begin + -- Parse date + + Year := Scan_Year; + Sep_Required := Scan_Separator (Date_Separator); + + Month := Scan_Month; + Scan_Separator (Sep_Required, Date_Separator); + + Day := Scan_Day; + + if Index < Date'Last and then Symbol = 'T' then + Advance; + + -- Parse time + + Hour := Scan_Hour; + Sep_Required := Scan_Separator (Hour_Separator); + + Minute := Scan_Minute; + Scan_Separator (Sep_Required, Hour_Separator); + + Second := Scan_Second; + + -- [('Z' | ('.' | ',') s{s} | ('+'|'-')hh:mm)] + + if Index <= Date'Last then + + -- Suffix 'Z' just confirms that this is an UTC time. No further + -- action needed. + + if Symbol = 'Z' then + Advance; + + -- A decimal fraction shall have at least one digit, and has as + -- many digits as supported by the underlying implementation. + -- The valid decimal separators are those specified in ISO 31-0, + -- i.e. the comma [,] or full stop [.]. Of these, the comma is + -- the preferred separator of ISO-8861. + + elsif Symbol = ',' or else Symbol = '.' then + Advance; -- past decimal separator + Subsec := Scan_Subsecond; + + -- Difference between local time and UTC: It shall be expressed + -- as positive (i.e. with the leading plus sign [+]) if the local + -- time is ahead of or equal to UTC of day and as negative (i.e. + -- with the leading minus sign [-]) if it is behind UTC of day. + -- The minutes time element of the difference may only be omitted + -- if the difference between the time scales is exactly an + -- integral number of hours. + + elsif Symbol = '+' or else Symbol = '-' then + Local_Sign := Symbol; + Advance; + Local_Hour := Scan_Hour; + + -- Past ':' + + if Index < Date'Last and then Symbol = Hour_Separator then + Advance; + Local_Minute := Scan_Minute; + end if; + + -- Compute local displacement + + Local_Disp := Local_Hour * 3600.0 + Local_Minute * 60.0; + else + raise Wrong_Syntax; + end if; + end if; + end if; + + -- Sanity checks. The check on Index ensures that there are no trailing + -- characters. + + if Index /= Date'Length + 1 + or else not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Subsec'Valid + or else not Local_Hour'Valid + or else not Local_Minute'Valid + then + raise Wrong_Syntax; + end if; + + -- Compute time without local displacement + + if Local_Sign = ' ' then + Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec); + + -- Compute time with positive local displacement + + elsif Local_Sign = '+' then + Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) + - Local_Disp; + + -- Compute time with negative local displacement + + elsif Local_Sign = '-' then + Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) + + Local_Disp; + end if; + + -- Notify that the input string was successfully parsed + + Success := True; + + exception + when End_Of_Source_Reached | + Wrong_Syntax => + Success := False; + end Parse_ISO_8861_UTC; + ----------- -- Value -- ----------- @@ -757,11 +1161,22 @@ package body GNAT.Calendar.Time_IO is -- Local Declarations + Success : Boolean; Time_Start : Natural := 1; + Time : Ada.Calendar.Time; -- Start of processing for Value begin + -- Let's try parsing Date as a supported ISO-8861 format. If we do not + -- succeed, then retry using all the other GNAT supported formats. + + Parse_ISO_8861_UTC (Date, Time, Success); + + if Success then + return Time; + end if; + -- Length checks if D_Length /= 8 diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads index fa8d802eb67..8b93518f529 100644 --- a/gcc/ada/g-catiio.ads +++ b/gcc/ada/g-catiio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2013, AdaCore -- +-- Copyright (C) 1999-2017, 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- -- @@ -141,6 +141,18 @@ package GNAT.Calendar.Time_IO is -- mmm dd, yyyy - month spelled out -- dd mmm yyyy - month spelled out -- + -- The following ISO-8861 format expressed as a regular expression is also + -- supported: + -- + -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) + -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] + -- + -- Examples: + -- + -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 + -- 2017-04-14T14:47:06,1234 20170414T14:47:06.1234 + -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 + -- Constraint_Error is raised if the input string is malformed (does not -- conform to one of the above dates, or has an invalid time string), or -- the resulting time is not valid. diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index f023d721824..15efcef5519 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1053,7 +1053,7 @@ package body Inline is -- generic, so that the proper global references are preserved. -- Note that we do not do this at the library level, because it is not - -- needed, and furthermore this causes trouble if front end inlining + -- needed, and furthermore this causes trouble if front-end inlining -- is activated (-gnatN). if In_Instance and then Scope (Current_Scope) /= Standard_Standard then @@ -1417,7 +1417,7 @@ package body Inline is -- which typically are not helper subprograms, which also avoids getting -- spurious messages on calls that cannot be inlined. - elsif Is_Subp_Or_Entry_Inside_Protected (Id) then + elsif Within_Protected_Type (Id) then return False; -- Do not inline predicate functions (treated specially by GNATprove) @@ -1481,7 +1481,7 @@ package body Inline is pragma Assert (Msg (Msg'Last) = '?'); - -- Legacy front end inlining model + -- Legacy front-end inlining model if not Back_End_Inlining then @@ -1514,7 +1514,7 @@ package body Inline is Error_Msg_NE (Msg & "p?", N, Subp); end if; - -- New semantics relying on back end inlining + -- New semantics relying on back-end inlining elsif Is_Serious then @@ -1592,15 +1592,6 @@ package body Inline is -- body N has no local declarations and its unique statement is a single -- extended return statement with a handled statements sequence. - procedure Generate_Subprogram_Body - (N : Node_Id; - Body_To_Inline : out Node_Id); - -- Generate a parameterless duplicate of subprogram body N. Occurrences - -- of pragmas referencing the formals are removed since they have no - -- meaning when the body is inlined and the formals are rewritten (the - -- analysis of the non-inlined body will handle these pragmas properly). - -- A new internal name is associated with Body_To_Inline. - procedure Split_Unconstrained_Function (N : Node_Id; Spec_Id : Entity_Id); @@ -1616,6 +1607,63 @@ package body Inline is -------------------------- procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is + + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id); + -- Generate a parameterless duplicate of subprogram body N. Note that + -- occurrences of pragmas referencing the formals are removed since + -- they have no meaning when the body is inlined and the formals are + -- rewritten (the analysis of the non-inlined body will handle these + -- pragmas). A new internal name is associated with Body_To_Inline. + + ----------------------------- + -- Generate_Body_To_Inline -- + ----------------------------- + + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id) + is + begin + -- Within an instance, the body to inline must be treated as a + -- nested generic so that proper global references are preserved. + + -- Note that we do not do this at the library level, because it + -- is not needed, and furthermore this causes trouble if front + -- end inlining is activated (-gnatN). + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Body_To_Inline := Copy_Generic_Node (N, Empty, True); + else + Body_To_Inline := Copy_Separate_Tree (N); + end if; + + -- Remove aspects/pragmas that have no meaning in an inlined body + + Remove_Aspects_And_Pragmas (Body_To_Inline); + + -- We need to capture references to the formals in order + -- to substitute the actuals at the point of inlining, i.e. + -- instantiation. To treat the formals as globals to the body to + -- inline, we nest it within a dummy parameterless subprogram, + -- declared within the real one. + + Set_Parameter_Specifications + (Specification (Body_To_Inline), No_List); + + -- A new internal name is associated with Body_To_Inline to avoid + -- conflicts when the non-inlined body N is analyzed. + + Set_Defining_Unit_Name (Specification (Body_To_Inline), + Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); + Set_Corresponding_Spec (Body_To_Inline, Empty); + end Generate_Subprogram_Body; + + -- Local variables + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); Original_Body : Node_Id; Body_To_Analyze : Node_Id; @@ -1626,7 +1674,7 @@ package body Inline is -- Within an instance, the body to inline must be treated as a nested -- generic, so that the proper global references are preserved. We -- do not do this at the library level, because it is not needed, and - -- furthermore this causes trouble if front end inlining is activated + -- furthermore this causes trouble if front-end inlining is activated -- (-gnatN). if In_Instance @@ -1716,51 +1764,6 @@ package body Inline is and then Present (Handled_Statement_Sequence (Ret_Node)); end Can_Split_Unconstrained_Function; - ----------------------------- - -- Generate_Body_To_Inline -- - ----------------------------- - - procedure Generate_Subprogram_Body - (N : Node_Id; - Body_To_Inline : out Node_Id) - is - begin - -- Within an instance, the body to inline must be treated as a nested - -- generic, so that the proper global references are preserved. - - -- Note that we do not do this at the library level, because it - -- is not needed, and furthermore this causes trouble if front - -- end inlining is activated (-gnatN). - - if In_Instance - and then Scope (Current_Scope) /= Standard_Standard - then - Body_To_Inline := Copy_Generic_Node (N, Empty, True); - else - Body_To_Inline := Copy_Separate_Tree (N); - end if; - - -- Remove all aspects/pragmas that have no meaning in an inlined body - - Remove_Aspects_And_Pragmas (Body_To_Inline); - - -- We need to capture references to the formals in order - -- to substitute the actuals at the point of inlining, i.e. - -- instantiation. To treat the formals as globals to the body to - -- inline, we nest it within a dummy parameterless subprogram, - -- declared within the real one. - - Set_Parameter_Specifications - (Specification (Body_To_Inline), No_List); - - -- A new internal name is associated with Body_To_Inline to avoid - -- conflicts when the non-inlined body N is analyzed. - - Set_Defining_Unit_Name (Specification (Body_To_Inline), - Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); - Set_Corresponding_Spec (Body_To_Inline, Empty); - end Generate_Subprogram_Body; - ---------------------------------- -- Split_Unconstrained_Function -- ---------------------------------- @@ -1945,14 +1948,14 @@ package body Inline is Parameter_Associations => Actual_List); end; - -- Generate + -- Generate: -- declare -- New_Obj : ... -- begin - -- main_1__F1b (New_Obj, ...); - -- return Obj; - -- end B10b; + -- Proc (New_Obj, ...); + -- return New_Obj; + -- end; Blk_Stmt := Make_Block_Statement (Loc, @@ -2922,8 +2925,8 @@ package body Inline is -- The semantic analyzer checked that frontend-inlined functions -- returning unconstrained types have no declarations and have -- a single extended return statement. As part of its processing - -- the function was split in two subprograms: a procedure P and - -- a function F that has a block with a call to procedure P (see + -- the function was split in two subprograms: a procedure P' and + -- a function F' that has a block with a call to procedure P' (see -- Split_Unconstrained_Function). else @@ -3269,7 +3272,7 @@ package body Inline is -- avoid generating undesired extra calls and goto statements. -- Given: - -- function Func (...) return ... + -- function Func (...) return String is -- begin -- declare -- Result : String (1 .. 4); @@ -3277,7 +3280,7 @@ package body Inline is -- Proc (Result, ...); -- return Result; -- end; - -- end F; + -- end Func; -- Result : String := Func (...); @@ -3526,7 +3529,7 @@ package body Inline is return True; end if; - -- Then declarations excluded only for front end inlining + -- Then declarations excluded only for front-end inlining if Back_End_Inlining then null; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b3d9defbc12..441dad584cc 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12649,9 +12649,6 @@ package body Sem_Ch13 is -------------------------------- procedure Resolve_Aspect_Expressions (E : Entity_Id) is - ASN : Node_Id; - A_Id : Aspect_Id; - Expr : Node_Id; function Resolve_Name (N : Node_Id) return Traverse_Result; -- Verify that all identifiers in the expression, with the exception @@ -12696,84 +12693,92 @@ package body Sem_Ch13 is procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name); + ASN : Node_Id := First_Rep_Item (E); + -- Start of processing for Resolve_Aspect_Expressions begin - ASN := First_Rep_Item (E); - while Present (ASN) loop - if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then - A_Id := Get_Aspect_Id (ASN); - Expr := Expression (ASN); + -- Need to make sure discriminants, if any, are directly visible - case A_Id is + Push_Scope_And_Install_Discriminants (E); - -- For now we only deal with aspects that do not generate - -- subprograms, or that may mention current instances of - -- types. These will require special handling (???TBD). + while Present (ASN) loop + if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then + declare + A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); + Expr : constant Node_Id := Expression (ASN); + begin + case A_Id is + -- For now we only deal with aspects that do not generate + -- subprograms, or that may mention current instances of + -- types. These will require special handling (???TBD). - when Aspect_Invariant - | Aspect_Predicate - | Aspect_Predicate_Failure - => - null; + when Aspect_Invariant + | Aspect_Predicate + | Aspect_Predicate_Failure + => + null; - when Aspect_Dynamic_Predicate - | Aspect_Static_Predicate - => - -- Build predicate function specification and preanalyze - -- expression after type replacement. + when Aspect_Dynamic_Predicate + | Aspect_Static_Predicate + => + -- Build predicate function specification and preanalyze + -- expression after type replacement. - if No (Predicate_Function (E)) then - declare - FDecl : constant Node_Id := - Build_Predicate_Function_Declaration (E); - pragma Unreferenced (FDecl); - begin - Resolve_Aspect_Expression (Expr); - end; - end if; + if No (Predicate_Function (E)) then + declare + FDecl : constant Node_Id := + Build_Predicate_Function_Declaration (E); + pragma Unreferenced (FDecl); + begin + Resolve_Aspect_Expression (Expr); + end; + end if; - when Pre_Post_Aspects => - null; + when Pre_Post_Aspects => + null; - when Aspect_Iterable => - if Nkind (Expr) = N_Aggregate then - declare - Assoc : Node_Id; + when Aspect_Iterable => + if Nkind (Expr) = N_Aggregate then + declare + Assoc : Node_Id; - begin - Assoc := First (Component_Associations (Expr)); - while Present (Assoc) loop - Find_Direct_Name (Expression (Assoc)); - Next (Assoc); - end loop; - end; - end if; + begin + Assoc := First (Component_Associations (Expr)); + while Present (Assoc) loop + Find_Direct_Name (Expression (Assoc)); + Next (Assoc); + end loop; + end; + end if; - when others => - if Present (Expr) then - case Aspect_Argument (A_Id) is - when Expression - | Optional_Expression - => - Analyze_And_Resolve (Expression (ASN)); - - when Name - | Optional_Name - => - if Nkind (Expr) = N_Identifier then - Find_Direct_Name (Expr); - - elsif Nkind (Expr) = N_Selected_Component then - Find_Selected_Component (Expr); - end if; - end case; - end if; - end case; + when others => + if Present (Expr) then + case Aspect_Argument (A_Id) is + when Expression + | Optional_Expression + => + Analyze_And_Resolve (Expr); + + when Name + | Optional_Name + => + if Nkind (Expr) = N_Identifier then + Find_Direct_Name (Expr); + + elsif Nkind (Expr) = N_Selected_Component then + Find_Selected_Component (Expr); + end if; + end case; + end if; + end case; + end; end if; ASN := Next_Rep_Item (ASN); end loop; + + Uninstall_Discriminants_And_Pop_Scope (E); end Resolve_Aspect_Expressions; ------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b1ecf5285f1..90abf1a8ede 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16241,9 +16241,6 @@ package body Sem_Ch3 is -- Check whether the parent type is a generic formal, or derives -- directly or indirectly from one. - function Find_Partial_View (T : Entity_Id) return Entity_Id; - -- Return the partial view for a type entity T, when there is one - ------------------------ -- Comes_From_Generic -- ------------------------ @@ -16270,28 +16267,6 @@ package body Sem_Ch3 is end if; end Comes_From_Generic; - ----------------------- - -- Find_Partial_View -- - ----------------------- - - function Find_Partial_View (T : Entity_Id) return Entity_Id is - Partial_View : Entity_Id; - - begin - -- Look for the associated private type declaration - - Partial_View := First_Entity (Scope (T)); - loop - exit when No (Partial_View) - or else (Has_Private_Declaration (Partial_View) - and then Full_View (Partial_View) = T); - - Next_Entity (Partial_View); - end loop; - - return Partial_View; - end Find_Partial_View; - -- Local variables Def : constant Node_Id := Type_Definition (N); @@ -16311,14 +16286,15 @@ package body Sem_Ch3 is then declare Partial_View : constant Entity_Id := - Find_Partial_View (Parent_Type); + Incomplete_Or_Partial_View (Parent_Type); begin - -- If the partial view was not found then the parent type is not a - -- private type. Otherwise check that the partial view is declared - -- as tagged. + -- If the partial view was not found then the parent type is not + -- a private type. Otherwise check if the partial view is a tagged + -- private type. if Present (Partial_View) + and then Is_Private_Type (Partial_View) and then not Is_Tagged_Type (Partial_View) then Error_Msg_NE @@ -16515,7 +16491,7 @@ package body Sem_Ch3 is begin -- Look for the associated private type declaration - Partial_View := Find_Partial_View (T); + Partial_View := Incomplete_Or_Partial_View (T); -- If the partial view was not found then the source code has -- errors and the transformation is not needed. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 841aff8a5db..3da7987fa57 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -527,10 +527,11 @@ package body Sem_Ch7 is -- processing for inlined bodies. For them, we traverse the syntactic -- tree and record which subprograms are actually referenced from it. -- This makes it possible to compute a much smaller set of externally - -- visible subprograms, which can have a significant impact on the - -- inlining decisions made in the back end. We do it only for inlined - -- bodies because they are supposed to be reasonably small and tree - -- traversal is very expensive. + -- visible subprograms in the absence of generic bodies, which can + -- have a significant impact on the inlining decisions made in the + -- back end and the removal of out-of-line bodies from the object + -- code. We do it only for inlined bodies because they are supposed + -- to be reasonably small and tree traversal is very expensive. -- Note that even this special processing is not optimal for inlined -- bodies, because we treat all inlined subprograms alike. An optimal diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 1dd8410b000..d5f724d5e63 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1161,7 +1161,6 @@ package body Sem_Dim is | N_Qualified_Expression | N_Selected_Component | N_Slice - | N_Type_Conversion | N_Unchecked_Type_Conversion => Analyze_Dimension_Has_Etype (N); @@ -1191,7 +1190,17 @@ package body Sem_Dim is when N_Subtype_Declaration => Analyze_Dimension_Subtype_Declaration (N); + when N_Type_Conversion => + if In_Instance + and then Exists (Dimensions_Of (Expression (N))) + then + Set_Dimensions (N, Dimensions_Of (Expression (N))); + else + Analyze_Dimension_Has_Etype (N); + end if; + when N_Unary_Op => + Analyze_Dimension_Unary_Op (N); when others => @@ -1378,10 +1387,23 @@ package body Sem_Dim is -- A type conversion may have been inserted to rewrite other -- expressions, e.g. function returns. Dimensions are those of - -- the target type. + -- the target type, unless this is a conversion in an instance, + -- in which case the proper dimensions are those of the operand, elsif Nkind (N) = N_Type_Conversion then - return Dimensions_Of (Etype (N)); + if In_Instance + and then Is_Generic_Actual_Type (Etype (Expression (N))) + then + return Dimensions_Of (Etype (Expression (N))); + + elsif In_Instance + and then Exists (Dimensions_Of (Expression (N))) + then + return Dimensions_Of (Expression (N)); + + else + return Dimensions_Of (Etype (N)); + end if; -- Otherwise return the default dimensions diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ea5618f383d..28713c23d68 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5455,6 +5455,13 @@ package body Sem_Res is Resolve (L, B_Typ); Resolve (R, TR); + -- If both operands are universal and the context is a floating + -- point type, the operands are resolved to the type of the context. + + elsif Is_Floating_Point_Type (B_Typ) then + Resolve (L, B_Typ); + Resolve (R, B_Typ); + else Set_Mixed_Mode_Operand (L, TR); Set_Mixed_Mode_Operand (R, TL); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c4d09a29e99..0440d89edd2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15545,34 +15545,6 @@ package body Sem_Util is and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; end Is_Subprogram_Stub_Without_Prior_Declaration; - --------------------------------------- - -- Is_Subp_Or_Entry_Inside_Protected -- - --------------------------------------- - - function Is_Subp_Or_Entry_Inside_Protected (E : Entity_Id) return Boolean is - Scop : Entity_Id; - - begin - case Ekind (E) is - when Entry_Kind - | Subprogram_Kind - => - Scop := Scope (E); - - while Present (Scop) loop - if Ekind (Scop) = E_Protected_Type then - return True; - end if; - Scop := Scope (Scop); - end loop; - - return False; - - when others => - return False; - end case; - end Is_Subp_Or_Entry_Inside_Protected; - -------------------------- -- Is_Suspension_Object -- -------------------------- @@ -22585,6 +22557,24 @@ package body Sem_Util is return Is_Init_Proc (S); end Within_Init_Proc; + --------------------------- + -- Within_Protected_Type -- + --------------------------- + + function Within_Protected_Type (E : Entity_Id) return Boolean is + Scop : Entity_Id := Scope (E); + + begin + while Present (Scop) loop + if Ekind (Scop) = E_Protected_Type then + return True; + end if; + Scop := Scope (Scop); + end loop; + + return False; + end Within_Protected_Type; + ------------------ -- Within_Scope -- ------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4331b2405ec..7d3bd0920d7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1839,10 +1839,6 @@ package Sem_Util is -- Return True if N is a subprogram stub with no prior subprogram -- declaration. - function Is_Subp_Or_Entry_Inside_Protected (E : Entity_Id) return Boolean; - -- Return True if E is an entry or a subprogram that is part (directly or - -- in a nested way) of a protected type. - function Is_Suspension_Object (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes Suspension_Object defined -- in Ada.Synchronous_Task_Control. @@ -2584,6 +2580,9 @@ package Sem_Util is function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc + function Within_Protected_Type (E : Entity_Id) return Boolean; + -- Returns True if entity E is declared within a protected type + function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean; -- Returns True if entity E is declared within scope S -- 2.30.2