+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch7.adb: Update comment.
+
+2017-09-06 Yannick Moy <moy@adacore.com>
+
+ * 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 <moy@adacore.com>
+
+ * sem_ch3.adb (Derived_Type_Declaration): Use
+ Incomplete_Or_Partial_View rather than local Find_Partial_View.
+
+2017-09-06 Javier Miranda <miranda@adacore.com>
+
+ * g-catiio.ads, g-catiio.adb (Value): Extended to parse an UTC time
+ following ISO-8861.
+
+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <duff@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
* a-comlin.adb, exp_aggr.adb, exp_ch6.adb, frontend.adb, gnatbind.adb,
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
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;
-- 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);
-- --
-- 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- --
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 --
-----------
"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);
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 --
-----------
-- 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
-- --
-- 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- --
-- 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.
-- 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
-- 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)
pragma Assert (Msg (Msg'Last) = '?');
- -- Legacy front end inlining model
+ -- Legacy front-end inlining model
if not Back_End_Inlining then
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
-- 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);
--------------------------
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;
-- 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
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 --
----------------------------------
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,
-- 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
-- avoid generating undesired extra calls and goto statements.
-- Given:
- -- function Func (...) return ...
+ -- function Func (...) return String is
-- begin
-- declare
-- Result : String (1 .. 4);
-- Proc (Result, ...);
-- return Result;
-- end;
- -- end F;
+ -- end Func;
-- Result : String := Func (...);
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;
--------------------------------
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
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;
-------------------------
-- 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 --
------------------------
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);
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
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.
-- 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
| N_Qualified_Expression
| N_Selected_Component
| N_Slice
- | N_Type_Conversion
| N_Unchecked_Type_Conversion
=>
Analyze_Dimension_Has_Etype (N);
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 =>
-- 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
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);
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 --
--------------------------
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 --
------------------
-- 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.
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
projects / gcc.git / commitdiff