+2014-07-31 Robert Dewar <dewar@adacore.com>
+
+ * par-ch13.adb (Get_Aspect_Specifications): Set Inside_Depends.
+ * par-ch2.adb (P_Pragma): Set Inside_Depends.
+ * par-ch4.adb (P_Simple_Expression): Pass Inside_Depends to
+ Check_Unary_Plus_Or_Minus.
+ * scans.ads (Inside_Depends): New flag.
+ * scng.adb (Scan): Pass Inside_Depends to Check_Arrow.
+ * style.ads: Add Inside_Depends parameter to Check_Arrow Add
+ Inside_Depends parameter to Check_Unary_Plus_Or_Minus.
+ * styleg.adb (Check_Arrow): Handle Inside_Depends case.
+ (Check_Unary_Plus_Or_Minus): Handle Inside_Depends case.
+ * styleg.ads: Add Inside_Depends parameter to Check_Arrow Add.
+ Inside_Depends parameter to Check_Unary_Plus_Or_Minus.
+
+2014-07-31 Javier Miranda <miranda@adacore.com>
+
+ * s-vaflop.adb Move the body of function T_To_G before
+ T_To_D. Required for frontend inlining.
+ * inline.adb (Has_Excluded_Contract): New subprogram used to
+ check if a subprogram inlined by the frontend has contracts
+ which cannot be inlined.
+
+2014-07-31 Bob Duff <duff@adacore.com>
+
+ * s-traceb.adb, s-traceb-hpux.adb, s-traceb-mastop.adb:
+ (Call_Chain): Add 1 to number of frames to skip, to account for
+ the fact that there's one more frame on the stack.
+
2014-07-31 Robert Dewar <dewar@adacore.com>
* checks.adb (Enable_Overflow_Check): More precise setting of
-- - functions that have exception handlers
-- - functions that have some enclosing body containing instantiations
-- that appear before the corresponding generic body.
+ -- - functions that have some of the following contracts (and the
+ -- sources are compiled with assertions enabled):
+ -- - Pre/post condition
+ -- - Contract cases
procedure Generate_Body_To_Inline
(N : Node_Id;
Max_Size : constant := 10;
Stat_Count : Integer := 0;
+ function Has_Excluded_Contract return Boolean;
+ -- Check for contracts that cannot be inlined
+
function Has_Excluded_Declaration (Decls : List_Id) return Boolean;
-- Check for declarations that make inlining not worthwhile
-- unconstrained type, the secondary stack is involved, and it
-- is not worth inlining.
+ ---------------------------
+ -- Has_Excluded_Contract --
+ ---------------------------
+
+ function Has_Excluded_Contract return Boolean is
+
+ function Check_Excluded_Contracts (E : Entity_Id) return Boolean;
+ -- Return True if the subprogram E has unsupported contracts
+
+ function Check_Excluded_Contracts (E : Entity_Id) return Boolean is
+ Items : constant Node_Id := Contract (E);
+
+ begin
+ if Present (Items) then
+ if Present (Pre_Post_Conditions (Items))
+ or else Present (Contract_Test_Cases (Items))
+ then
+ Cannot_Inline
+ ("cannot inline & (non-allowed contract)?",
+ N, Subp);
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Check_Excluded_Contracts;
+
+ Decl : Node_Id;
+ P_Id : Pragma_Id;
+ begin
+ if Check_Excluded_Contracts (Spec_Id)
+ or else Check_Excluded_Contracts (Body_Id)
+ then
+ return True;
+ end if;
+
+ -- Check pragmas located in the body which may generate contracts
+
+ if Present (Declarations (N)) then
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Pragma then
+ P_Id := Get_Pragma_Id (Pragma_Name (Decl));
+
+ if P_Id = Pragma_Contract_Cases or else
+ P_Id = Pragma_Pre or else
+ P_Id = Pragma_Precondition or else
+ P_Id = Pragma_Post or else
+ P_Id = Pragma_Postcondition
+ then
+ Cannot_Inline
+ ("cannot inline & (non-allowed contract)?",
+ N, Subp);
+ return True;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Excluded_Contract;
+
------------------------------
-- Has_Excluded_Declaration --
------------------------------
elsif Present (Body_To_Inline (Decl)) then
return False;
+ -- Cannot build the body to inline if the subprogram has unsupported
+ -- contracts that will be expanded into code (if assertions are not
+ -- enabled these pragmas will be removed by Generate_Body_To_Inline
+ -- to avoid reporting spurious errors).
+
+ elsif Assertions_Enabled
+ and then Has_Excluded_Contract
+ then
+ return False;
+
-- Subprograms that have return statements in the middle of the
-- body are inlined with gotos. GNATprove does not currently
-- support gotos, so we prevent such inlining.
Nxt := Next (Decl);
if Nkind (Decl) = N_Pragma
- and then Nam_In (Pragma_Name (Decl), Name_Unreferenced,
+ and then Nam_In (Pragma_Name (Decl), Name_Contract_Cases,
+ Name_Precondition,
+ Name_Postcondition,
+ Name_Unreferenced,
Name_Unmodified)
then
Remove (Decl);
Scan; -- past WITH
Aspects := Empty_List;
+ -- Loop to scan aspects
+
loop
OK := True;
end if;
end if;
+ -- Note if inside Depends aspect
+
+ if A_Id = Aspect_Depends then
+ Inside_Depends := True;
+ end if;
+
-- Parse the aspect definition depening on the expected
-- argument kind.
Aspect_Argument (A_Id) = Optional_Expression);
Set_Expression (Aspect, P_Expression);
end if;
+
+ -- Unconditionally reset flag for Inside_Depends
+
+ Inside_Depends := False;
end if;
-- Add the aspect to the resulting list only when it was properly
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
Import_Check_Required := False;
end if;
+ -- Set global to indicate if we are within a Depends pragma
+
+ if Chars (Ident_Node) = Name_Depends then
+ Inside_Depends := True;
+ end if;
+
-- Scan arguments. We assume that arguments are present if there is
-- a left paren, or if a semicolon is missing and there is another
-- token on the same line as the pragma name.
if Token = Tok_Left_Paren
or else (Token /= Tok_Semicolon
- and then not Token_Is_At_Start_Of_Line)
+ and then not Token_Is_At_Start_Of_Line)
then
Set_Pragma_Argument_Associations (Prag_Node, New_List);
T_Left_Paren;
Semicolon_Loc := Token_Ptr;
+ -- Cancel indication of being within Depends pragm. Can be done
+ -- unconditionally, since quicker than doing a test.
+
+ Inside_Depends := False;
+
-- Now we have two tasks left, we need to scan out the semicolon
-- following the pragma, and we have to call Par.Prag to process
-- the pragma. Normally we do them in this order, however, there
Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
if Style_Check then
- Style.Check_Unary_Plus_Or_Minus;
+ Style.Check_Unary_Plus_Or_Minus (Inside_Depends);
end if;
Scan; -- past operator
-- but it is not usable when frames with dynamically allocated space are
-- on the way.
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1);
- -- Same as the exported version, but takes Traceback as an Address
+-- procedure Call_Chain
+-- (Traceback : System.Address;
+-- Max_Len : Natural;
+-- Len : out Natural;
+-- Exclude_Min : System.Address := System.Null_Address;
+-- Exclude_Max : System.Address := System.Null_Address;
+-- Skip_Frames : Natural := 1);
+-- -- Same as the exported version, but takes Traceback as an Address
+-- ???See declaration in the spec for why this is temporarily commented out.
------------------
-- C_Call_Chain --
Max_Len : Natural) return Natural
is
Val : Natural;
-
begin
Call_Chain (Traceback, Max_Len, Val);
return Val;
begin
Call_Chain
(Traceback'Address, Max_Len, Len,
- Exclude_Min, Exclude_Max, Skip_Frames);
+ Exclude_Min, Exclude_Max, Skip_Frames + 1);
+ -- Skip one extra frame so we skip the other Call_Chain as well
end Call_Chain;
end System.Traceback;
use System.Machine_State_Operations;
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1);
- -- Same as the exported version, but takes Traceback as an Address
+-- procedure Call_Chain
+-- (Traceback : System.Address;
+-- Max_Len : Natural;
+-- Len : out Natural;
+-- Exclude_Min : System.Address := System.Null_Address;
+-- Exclude_Max : System.Address := System.Null_Address;
+-- Skip_Frames : Natural := 1);
+-- -- Same as the exported version, but takes Traceback as an Address
+-- ???See declaration in the spec for why this is temporarily commented out.
----------------
-- Call_Chain --
begin
Call_Chain
(Traceback'Address, Max_Len, Len,
- Exclude_Min, Exclude_Max, Skip_Frames);
+ Exclude_Min, Exclude_Max, Skip_Frames + 1);
+ -- Skip one extra frame so we skip the other Call_Chain as well
end Call_Chain;
------------------
package body System.Traceback is
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1);
- -- Same as the exported version, but takes Traceback as an Address
+-- procedure Call_Chain
+-- (Traceback : System.Address;
+-- Max_Len : Natural;
+-- Len : out Natural;
+-- Exclude_Min : System.Address := System.Null_Address;
+-- Exclude_Max : System.Address := System.Null_Address;
+-- Skip_Frames : Natural := 1);
+-- -- Same as the exported version, but takes Traceback as an Address
+-- ???See declaration in the spec for why this is temporarily commented out.
------------------
-- C_Call_Chain --
function C_Call_Chain
(Traceback : System.Address;
- Max_Len : Natural)
- return Natural
+ Max_Len : Natural) return Natural
is
Val : Natural;
-
begin
Call_Chain (Traceback, Max_Len, Val);
return Val;
begin
Call_Chain
(Traceback'Address, Max_Len, Len,
- Exclude_Min, Exclude_Max, Skip_Frames);
+ Exclude_Min, Exclude_Max, Skip_Frames + 1);
+ -- Skip one extra frame so we skip the other Call_Chain as well
end Call_Chain;
end System.Traceback;
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2014, 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- --
end Sub_G;
------------
- -- T_To_D --
+ -- T_To_G --
------------
- function T_To_D (X : T) return D is
+ -- This function must be located before T_To_D for frontend inlining
+
+ function T_To_G (X : T) return G is
begin
- return G_To_D (T_To_G (X));
- end T_To_D;
+ return G (X);
+ end T_To_G;
------------
- -- T_To_G --
+ -- T_To_D --
------------
- function T_To_G (X : T) return G is
+ function T_To_D (X : T) return D is
begin
- return G (X);
- end T_To_G;
+ return G_To_D (T_To_G (X));
+ end T_To_D;
-------------
-- Valid_D --
-- Is it really right for this to be a Name rather than a String, what
-- about the case of Wide_Wide_Characters???
+ Inside_Depends : Boolean := False;
+ -- Flag set True for parsing the argument of a Depends pragma or aspect
+ -- (used to allow/require non-standard style rules for =>+ with -gnatyt).
+
Inside_If_Expression : Nat := 0;
-- This is a counter that is set non-zero while scanning out an if
-- expression (incremented on entry, decremented on exit). It is used to
Token := Tok_Arrow;
if Style_Check then
- Style.Check_Arrow;
+ Style.Check_Arrow (Inside_Depends);
end if;
return;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
renames Style_Inst.Check_Apostrophe;
-- Called after scanning an apostrophe to check spacing
- procedure Check_Arrow
+ procedure Check_Arrow (Inside_Depends : Boolean := False)
renames Style_Inst.Check_Arrow;
-- Called after scanning out an arrow to check spacing
-- procedure is called only if THEN appears at the start of a line with
-- Token_Ptr pointing to the THEN keyword.
- procedure Check_Unary_Plus_Or_Minus
+ procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False)
renames Style_Inst.Check_Unary_Plus_Or_Minus;
-- Called after scanning a unary plus or minus to check spacing
-- Check_Arrow --
-----------------
- -- In check tokens mode (-gnatys), arrow must be surrounded by spaces
+ -- In check tokens mode (-gnatys), arrow must be surrounded by spaces,
+ -- except that within the argument of a Depends macro the required format
+ -- is =>+ rather than => +).
- procedure Check_Arrow is
+ procedure Check_Arrow (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
Require_Preceding_Space;
- Require_Following_Space;
+
+ if not Inside_Depends then
+ Require_Following_Space;
+
+ -- Special handling for Inside_Depends
+
+ else
+ if Source (Scan_Ptr) = ' '
+ and then Source (Scan_Ptr + 1) = '+'
+ then
+ Error_Space_Not_Allowed (Scan_Ptr);
+
+ elsif Source (Scan_Ptr) /= ' '
+ and then Source (Scan_Ptr) /= '+'
+ then
+ Require_Following_Space;
+ end if;
+ end if;
end if;
end Check_Arrow;
-- In check token mode (-gnatyt), unary plus or minus must not be
-- followed by a space.
- procedure Check_Unary_Plus_Or_Minus is
+ -- Annoying exception: if we have the sequence =>+ within a Depends pragma
+ -- or aspect, then we insist on a space rather than forbidding it.
+
+ procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
- Check_No_Space_After;
+ if not Inside_Depends then
+ Check_No_Space_After;
+ else
+ Require_Following_Space;
+ end if;
end if;
end Check_Unary_Plus_Or_Minus;
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S T Y L E G --
+-- S T Y L E G --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
procedure Check_Apostrophe;
-- Called after scanning an apostrophe to check spacing
- procedure Check_Arrow;
- -- Called after scanning out an arrow to check spacing
+ procedure Check_Arrow (Inside_Depends : Boolean := False);
+ -- Called after scanning out an arrow to check spacing. Inside_Depends is
+ -- true if the call is from an argument of the Depends pragma (where the
+ -- allowed/required format is =>+).
procedure Check_Attribute_Name (Reserved : Boolean);
-- The current token is an attribute designator. Check that it
-- would interfere with coverage testing). Handles case of THEN ABORT as
-- an exception, as well as PRAGMA after ELSE.
- procedure Check_Unary_Plus_Or_Minus;
- -- Called after scanning a unary plus or minus to check spacing
+ procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False);
+ -- Called after scanning a unary plus or minus to check spacing. The flag
+ -- Inside_Depends is set if we are scanning within a Depends pragma or
+ -- Aspect, in which case =>+ requires a following space).
procedure Check_Vertical_Bar;
-- Called after scanning a vertical bar to check spacing
projects / gcc.git / commitdiff