Skip to content

R
riscv-gcc-1
Commit 5e29ae82 by Arnaud Charlet
Options

[multiple changes] 

2012-12-05  Robert Dewar  <dewar@adacore.com>

	* lib-writ.adb (Write_ALI): Output T lines.
	* lib-writ.ads: Minor reformatting. Add documentation of T lines.
	* opt.ads (Generate_Target_Dependent_Info): New flag.
	* switch-c.adb (Scan_Switches): Recognize -gnatet switch
	(target dependent info).
	* ttypes.ads: Add four letter codes to declarations (for target
	dependent info).
	* usage.adb: Add line for -gnatet switch.

2012-12-05  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_prag.adb (Expand_N_Pragma): Add a call to expand
	pragma Loop_Variant.
	(Expand_Pragma_Loop_Assertion): Removed.
	(Expand_Pragma_Loop_Variant): New routine.
	* par-prag.adb: Remove Pragma_Loop_Assertion and add two new
	Pragma_Loop_Invariant and Pragma_Loop_Variant entries.
	* sem_attr.adb (Analyze_Attribute): Update the code which
	locates the enclosing pragma.
	* sem_prag.adb (Analyze_Pragma): Remove the code which analyzes
	pragma Loop_Assertion as the pragma is now obsolete. Add the
	machinery to checks the semantics of pragmas Loop_Invariant
	and Loop_Variant.
	(Check_Loop_Invariant_Variant_Placement): New routine.
	* snames.ads-tmpl: Remove name Loop_Assertion. Add new names
	Loop_Invariant and Loop_Variant.  Rename Name_Decreasing
	to Name_Decreases and Name_Increasing to Name_Increases.
	Remove the pragma Id for Loop_Assertion and add two new Ids for
	Loop_Invariant and Loop_Variant.

From-SVN: r194203
parent b9daa96e
Showing with 295 additions and 200 deletions
gcc/ada/ChangeLog
2012-12-05 Robert Dewar <dewar@adacore.com> 2012-12-05 Robert Dewar <dewar@adacore.com>
* lib-writ.adb (Write_ALI): Output T lines.
* lib-writ.ads: Minor reformatting. Add documentation of T lines.
* opt.ads (Generate_Target_Dependent_Info): New flag.
* switch-c.adb (Scan_Switches): Recognize -gnatet switch
(target dependent info).
* ttypes.ads: Add four letter codes to declarations (for target
dependent info).
* usage.adb: Add line for -gnatet switch.
2012-12-05 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb (Expand_N_Pragma): Add a call to expand
pragma Loop_Variant.
(Expand_Pragma_Loop_Assertion): Removed.
(Expand_Pragma_Loop_Variant): New routine.
* par-prag.adb: Remove Pragma_Loop_Assertion and add two new
Pragma_Loop_Invariant and Pragma_Loop_Variant entries.
* sem_attr.adb (Analyze_Attribute): Update the code which
locates the enclosing pragma.
* sem_prag.adb (Analyze_Pragma): Remove the code which analyzes
pragma Loop_Assertion as the pragma is now obsolete. Add the
machinery to checks the semantics of pragmas Loop_Invariant
and Loop_Variant.
(Check_Loop_Invariant_Variant_Placement): New routine.
* snames.ads-tmpl: Remove name Loop_Assertion. Add new names
Loop_Invariant and Loop_Variant. Rename Name_Decreasing
to Name_Decreases and Name_Increasing to Name_Increases.
Remove the pragma Id for Loop_Assertion and add two new Ids for
Loop_Invariant and Loop_Variant.
2012-12-05 Robert Dewar <dewar@adacore.com>
* gnatchop.adb, sem_attr.ads, sem_ch4.adb, sem_ch6.adb, exp_disp.adb, * gnatchop.adb, sem_attr.ads, sem_ch4.adb, sem_ch6.adb, exp_disp.adb,
atree.adb, sem_eval.adb: Minor reformatting. atree.adb, sem_eval.adb: Minor reformatting.
......
gcc/ada/exp_prag.adb
...@@ -69,7 +69,7 @@ package body Exp_Prag is ...@@ -69,7 +69,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Expand_Pragma_Loop_Assertion (N : Node_Id); procedure Expand_Pragma_Loop_Variant (N : Node_Id);
procedure Expand_Pragma_Psect_Object (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id);
procedure Expand_Pragma_Relative_Deadline (N : Node_Id); procedure Expand_Pragma_Relative_Deadline (N : Node_Id);
...@@ -191,8 +191,8 @@ package body Exp_Prag is ...@@ -191,8 +191,8 @@ package body Exp_Prag is
when Pragma_Interrupt_Priority => when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N); Expand_Pragma_Interrupt_Priority (N);
when Pragma_Loop_Assertion => when Pragma_Loop_Variant =>
Expand_Pragma_Loop_Assertion (N); Expand_Pragma_Loop_Variant (N);
when Pragma_Psect_Object => when Pragma_Psect_Object =>
Expand_Pragma_Psect_Object (N); Expand_Pragma_Psect_Object (N);
...@@ -795,20 +795,19 @@ package body Exp_Prag is ...@@ -795,20 +795,19 @@ package body Exp_Prag is
end if; end if;
end Expand_Pragma_Interrupt_Priority; end Expand_Pragma_Interrupt_Priority;
---------------------------------- --------------------------------
-- Expand_Pragma_Loop_Assertion -- -- Expand_Pragma_Loop_Variant --
---------------------------------- --------------------------------
-- Pragma Loop_Assertion is expanded in the following manner: -- Pragma Loop_Variant is expanded in the following manner:
-- Original code -- Original code
-- for | while ... loop -- for | while ... loop
-- <preceding source statements> -- <preceding source statements>
-- pragma Loop_Assertion -- pragma Loop_Variant
-- (Invariant => Invar_Expr, -- (Increases => Incr_Expr,
-- Variant => (Increasing => Incr_Expr, -- Decreases => Decr_Expr);
-- Decreasing => Decr_Expr));
-- <succeeding source statements> -- <succeeding source statements>
-- end loop; -- end loop;
...@@ -823,8 +822,6 @@ package body Exp_Prag is ...@@ -823,8 +822,6 @@ package body Exp_Prag is
-- for | while ... loop -- for | while ... loop
-- <preceding source statements> -- <preceding source statements>
-- pragma Assert (<Invar_Expr>);
-- if Flag then -- if Flag then
-- Old_1 := Curr_1; -- Old_1 := Curr_1;
-- Old_2 := Curr_2; -- Old_2 := Curr_2;
...@@ -846,7 +843,9 @@ package body Exp_Prag is ...@@ -846,7 +843,9 @@ package body Exp_Prag is
-- <succeeding source statements> -- <succeeding source statements>
-- end loop; -- end loop;
procedure Expand_Pragma_Loop_Assertion (N : Node_Id) is procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
Last_Var : constant Node_Id :=
Last (Pragma_Argument_Associations (N));
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Curr_Assign : List_Id := No_List; Curr_Assign : List_Id := No_List;
Flag_Id : Entity_Id := Empty; Flag_Id : Entity_Id := Empty;
...@@ -854,27 +853,23 @@ package body Exp_Prag is ...@@ -854,27 +853,23 @@ package body Exp_Prag is
Loop_Scop : Entity_Id; Loop_Scop : Entity_Id;
Loop_Stmt : Node_Id; Loop_Stmt : Node_Id;
Old_Assign : List_Id := No_List; Old_Assign : List_Id := No_List;
Variant : Node_Id;
procedure Process_Increase_Decrease procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
(Variant : Node_Id;
Is_Last : Boolean);
-- Process a single increasing / decreasing termination variant. Flag -- Process a single increasing / decreasing termination variant. Flag
-- Is_Last should be set when processing the last variant. -- Is_Last should be set when processing the last variant.
------------------------------- ---------------------
-- Process_Increase_Decrease -- -- Process_Variant --
------------------------------- ---------------------
procedure Process_Increase_Decrease procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
(Variant : Node_Id;
Is_Last : Boolean)
is
function Make_Op function Make_Op
(Loc : Source_Ptr; (Loc : Source_Ptr;
Curr_Val : Node_Id; Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id; Old_Val : Node_Id) return Node_Id;
-- Generate a comparison between Curr_Val and Old_Val depending on -- Generate a comparison between Curr_Val and Old_Val depending on
-- the argument name (Increases / Decreases). -- the change mode (Increases / Decreases) of the variant.
------------- -------------
-- Make_Op -- -- Make_Op --
...@@ -885,12 +880,11 @@ package body Exp_Prag is ...@@ -885,12 +880,11 @@ package body Exp_Prag is
Curr_Val : Node_Id; Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id Old_Val : Node_Id) return Node_Id
is is
Modif : constant Node_Id := First (Choices (Variant));
begin begin
if Chars (Modif) = Name_Increasing then if Chars (Variant) = Name_Increases then
return Make_Op_Gt (Loc, Curr_Val, Old_Val); return Make_Op_Gt (Loc, Curr_Val, Old_Val);
else pragma Assert (Chars (Modif) = Name_Decreasing); else pragma Assert (Chars (Variant) = Name_Decreases);
return Make_Op_Lt (Loc, Curr_Val, Old_Val); return Make_Op_Lt (Loc, Curr_Val, Old_Val);
end if; end if;
end Make_Op; end Make_Op;
...@@ -898,13 +892,14 @@ package body Exp_Prag is ...@@ -898,13 +892,14 @@ package body Exp_Prag is
-- Local variables -- Local variables
Expr : constant Node_Id := Expression (Variant); Expr : constant Node_Id := Expression (Variant);
Expr_Typ : constant Entity_Id := Etype (Expr);
Loc : constant Source_Ptr := Sloc (Expr); Loc : constant Source_Ptr := Sloc (Expr);
Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt); Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
Curr_Id : Entity_Id; Curr_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
Prag : Node_Id; Prag : Node_Id;
-- Start of processing for Process_Increase_Decrease -- Start of processing for Process_Variant
begin begin
-- All temporaries generated in this routine must be inserted before -- All temporaries generated in this routine must be inserted before
...@@ -959,8 +954,7 @@ package body Exp_Prag is ...@@ -959,8 +954,7 @@ package body Exp_Prag is
Insert_Action (Loop_Stmt, Insert_Action (Loop_Stmt,
Make_Object_Declaration (Loop_Loc, Make_Object_Declaration (Loop_Loc,
Defining_Identifier => Curr_Id, Defining_Identifier => Curr_Id,
Object_Definition => Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
New_Reference_To (Etype (Expr), Loop_Loc)));
-- Generate: -- Generate:
-- Old : <type of Expr>; -- Old : <type of Expr>;
...@@ -970,8 +964,7 @@ package body Exp_Prag is ...@@ -970,8 +964,7 @@ package body Exp_Prag is
Insert_Action (Loop_Stmt, Insert_Action (Loop_Stmt,
Make_Object_Declaration (Loop_Loc, Make_Object_Declaration (Loop_Loc,
Defining_Identifier => Old_Id, Defining_Identifier => Old_Id,
Object_Definition => Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
New_Reference_To (Etype (Expr), Loop_Loc)));
-- Restore original scope after all temporaries have been analyzed -- Restore original scope after all temporaries have been analyzed
...@@ -1066,12 +1059,7 @@ package body Exp_Prag is ...@@ -1066,12 +1059,7 @@ package body Exp_Prag is
Right_Opnd => New_Reference_To (Old_Id, Loc)), Right_Opnd => New_Reference_To (Old_Id, Loc)),
Then_Statements => New_List (Prag))); Then_Statements => New_List (Prag)));
end if; end if;
end Process_Increase_Decrease; end Process_Variant;
-- Local variables
Arg : Node_Id;
Invar : Node_Id := Empty;
-- Start of processing for Expand_Pragma_Loop_Assertion -- Start of processing for Expand_Pragma_Loop_Assertion
...@@ -1093,57 +1081,14 @@ package body Exp_Prag is ...@@ -1093,57 +1081,14 @@ package body Exp_Prag is
Loop_Scop := Entity (Identifier (Loop_Stmt)); Loop_Scop := Entity (Identifier (Loop_Stmt));
-- Process all pragma arguments -- Create the circuitry which verifies individual variants
Arg := First (Pragma_Argument_Associations (N));
while Present (Arg) loop
-- Termination variants appear as components in an aggregate
if Chars (Arg) = Name_Variant then Variant := First (Pragma_Argument_Associations (N));
declare
Variants : constant Node_Id := Expression (Arg);
Last_Var : constant Node_Id :=
Last (Component_Associations (Variants));
Variant : Node_Id;
begin
Variant := First (Component_Associations (Variants));
while Present (Variant) loop while Present (Variant) loop
Process_Increase_Decrease Process_Variant (Variant, Is_Last => Variant = Last_Var);
(Variant => Variant,
Is_Last => Variant = Last_Var);
Next (Variant); Next (Variant);
end loop; end loop;
end;
-- Invariant
else
Invar := Expression (Arg);
end if;
Next (Arg);
end loop;
-- Verify the invariant expression, generate:
-- pragma Assert (<Invar>);
-- Use the Sloc of the invariant for better error reporting
if Present (Invar) then
declare
Invar_Loc : constant Source_Ptr := Sloc (Invar);
begin
Insert_Action (N,
Make_Pragma (Invar_Loc,
Chars => Name_Assert,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Invar_Loc,
Expression => Relocate_Node (Invar)))));
end;
end if;
-- Construct the segment which stores the old values of all expressions. -- Construct the segment which stores the old values of all expressions.
-- Generate: -- Generate:
...@@ -1151,18 +1096,14 @@ package body Exp_Prag is ...@@ -1151,18 +1096,14 @@ package body Exp_Prag is
-- <Old_Assign> -- <Old_Assign>
-- end if; -- end if;
if Present (Old_Assign) then
Insert_Action (N, Insert_Action (N,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => New_Reference_To (Flag_Id, Loc), Condition => New_Reference_To (Flag_Id, Loc),
Then_Statements => Old_Assign)); Then_Statements => Old_Assign));
end if;
-- Update the values of all expressions -- Update the values of all expressions
if Present (Curr_Assign) then
Insert_Actions (N, Curr_Assign); Insert_Actions (N, Curr_Assign);
end if;
-- Add the assertion circuitry to test all changes in expressions. -- Add the assertion circuitry to test all changes in expressions.
-- Generate: -- Generate:
...@@ -1172,7 +1113,6 @@ package body Exp_Prag is ...@@ -1172,7 +1113,6 @@ package body Exp_Prag is
-- Flag := True; -- Flag := True;
-- end if; -- end if;
if Present (If_Stmt) then
Insert_Action (N, Insert_Action (N,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => New_Reference_To (Flag_Id, Loc), Condition => New_Reference_To (Flag_Id, Loc),
...@@ -1181,13 +1121,12 @@ package body Exp_Prag is ...@@ -1181,13 +1121,12 @@ package body Exp_Prag is
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (Flag_Id, Loc), Name => New_Reference_To (Flag_Id, Loc),
Expression => New_Reference_To (Standard_True, Loc))))); Expression => New_Reference_To (Standard_True, Loc)))));
end if;
-- Note: the pragma has been completely transformed into a sequence of -- Note: the pragma has been completely transformed into a sequence of
-- corresponding declarations and statements. We leave it in the tree -- corresponding declarations and statements. We leave it in the tree
-- for documentation purposes. It will be ignored by the backend. -- for documentation purposes. It will be ignored by the backend.
end Expand_Pragma_Loop_Assertion; end Expand_Pragma_Loop_Variant;
-------------------------------- --------------------------------
-- Expand_Pragma_Psect_Object -- -- Expand_Pragma_Psect_Object --
......
gcc/ada/lib-writ.adb
...@@ -49,6 +49,7 @@ with Sinput; use Sinput; ...@@ -49,6 +49,7 @@ with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Stringt; use Stringt; with Stringt; use Stringt;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname; with Uname; use Uname;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
...@@ -1440,6 +1441,93 @@ package body Lib.Writ is ...@@ -1440,6 +1441,93 @@ package body Lib.Writ is
Output_Alfa; Output_Alfa;
end if; end if;
-- Output target dependent information if needed
if Generate_Target_Dependent_Info then
Gen_TDI : declare
subtype Str4 is String (1 .. 4);
procedure Gen_TDI_Bool (Code : Str4; Val : Boolean);
-- Generate T line for Bool value
procedure Gen_TDI_Nat (Code : Str4; Val : Int);
-- Generate T line for Pos or Nat value
------------------
-- Gen_TDI_Bool --
------------------
procedure Gen_TDI_Bool (Code : Str4; Val : Boolean) is
begin
Write_Info_Initiate ('T');
Write_Info_Char (' ');
Write_Info_Str (Code);
if Val then
Write_Info_Str (" TRUE");
else
Write_Info_Str (" FALSE");
end if;
Write_Info_EOL;
end Gen_TDI_Bool;
-----------------
-- Gen_TDI_Nat --
-----------------
procedure Gen_TDI_Nat (Code : Str4; Val : Int) is
begin
Write_Info_Initiate ('T');
Write_Info_Char (' ');
Write_Info_Str (Code);
Write_Info_Char (' ');
Write_Info_Nat (Val);
Write_Info_EOL;
end Gen_TDI_Nat;
-- Start of processing for Gen_TDI
begin
Gen_TDI_Nat ("SINS", Standard_Short_Short_Integer_Size);
Gen_TDI_Nat ("SINW", Standard_Short_Short_Integer_Width);
Gen_TDI_Nat ("SHIS", Standard_Short_Integer_Size);
Gen_TDI_Nat ("SHIW", Standard_Short_Integer_Width);
Gen_TDI_Nat ("INTS", Standard_Integer_Size);
Gen_TDI_Nat ("INTW", Standard_Integer_Width);
Gen_TDI_Nat ("LINS", Standard_Long_Integer_Size);
Gen_TDI_Nat ("LINW", Standard_Long_Integer_Width);
Gen_TDI_Nat ("LLIS", Standard_Long_Long_Integer_Size);
Gen_TDI_Nat ("LLIW", Standard_Long_Long_Integer_Width);
Gen_TDI_Nat ("SFLS", Standard_Short_Float_Size);
Gen_TDI_Nat ("SFLD", Standard_Short_Float_Digits);
Gen_TDI_Nat ("FLTS", Standard_Float_Size);
Gen_TDI_Nat ("FLTD", Standard_Float_Digits);
Gen_TDI_Nat ("LFLS", Standard_Long_Float_Size);
Gen_TDI_Nat ("LFLD", Standard_Long_Float_Digits);
Gen_TDI_Nat ("LLFS", Standard_Long_Long_Float_Size);
Gen_TDI_Nat ("LLFD", Standard_Long_Long_Float_Digits);
Gen_TDI_Nat ("CHAS", Standard_Character_Size);
Gen_TDI_Nat ("WCHS", Standard_Wide_Character_Size);
Gen_TDI_Nat ("WWCS", Standard_Wide_Wide_Character_Size);
Gen_TDI_Nat ("ADRS", System_Address_Size);
Gen_TDI_Nat ("MBMP", System_Max_Binary_Modulus_Power);
Gen_TDI_Nat ("MNMP", System_Max_Nonbinary_Modulus_Power);
Gen_TDI_Nat ("SUNI", System_Storage_Unit);
Gen_TDI_Nat ("WRDS", System_Word_Size);
Gen_TDI_Nat ("TICK", System_Tick_Nanoseconds);
Gen_TDI_Nat ("WCTS", Interfaces_Wchar_T_Size);
Gen_TDI_Nat ("MAXA", Maximum_Alignment);
Gen_TDI_Nat ("ALLA", System_Allocator_Alignment);
Gen_TDI_Nat ("MUNF", Max_Unaligned_Field);
Gen_TDI_Bool ("BEND", Bytes_Big_Endian);
Gen_TDI_Bool ("STRA", Target_Strict_Alignment);
Gen_TDI_Nat ("DFLA", Target_Double_Float_Alignment);
Gen_TDI_Nat ("DSCA", Target_Double_Scalar_Alignment);
end Gen_TDI;
end if;
-- Output final blank line and we are done. This final blank line is -- Output final blank line and we are done. This final blank line is
-- probably junk, but we don't feel like making an incompatible change! -- probably junk, but we don't feel like making an incompatible change!
......
gcc/ada/lib-writ.ads
...@@ -801,21 +801,40 @@ package Lib.Writ is ...@@ -801,21 +801,40 @@ package Lib.Writ is
-------------------------- --------------------------
-- The cross-reference data follows the dependency lines. See the spec of -- The cross-reference data follows the dependency lines. See the spec of
-- Lib.Xref for details on the format of this data. -- Lib.Xref in file lib-xref.ads for details on the format of this data.
--------------------------------- ---------------------------------
-- Source Coverage Obligations -- -- Source Coverage Obligations --
--------------------------------- ---------------------------------
-- The Source Coverage Obligation (SCO) information follows the cross- -- The Source Coverage Obligation (SCO) information follows the cross-
-- reference data. See the spec of Par_SCO for full details of the format. -- reference data. See the spec of Par_SCO in file par_sco.ads for full
-- details of the format.
---------------------- ----------------------
-- Alfa Information -- -- Alfa Information --
---------------------- ----------------------
-- The Alfa information follows the SCO information. See the spec of Alfa -- The Alfa information follows the SCO information. See the spec of Alfa
-- for full details of the format. -- in file alfa.ads for full details of the format.
-------------------------------------
-- T Target Dependent Information --
-------------------------------------
-- This section is present if the option to generate target dependent
-- information is present (this flag is set by the -gnatT switch). The
-- format of T lines is:
-- T key val
-- There is one line for each constant declared in the Ttypes package
-- key is the four letter code (which can be found as a comment on each
-- of the constant declarations in Ttypes).
-- val is the value of the constant, which is either a non-negative
-- decimal constant, or TRUE or FALSE for a Boolean value.
---------------------- ----------------------
-- Global Variables -- -- Global Variables --
......
gcc/ada/opt.ads
...@@ -658,6 +658,11 @@ package Opt is ...@@ -658,6 +658,11 @@ package Opt is
-- True when switch -fdebug-instances is used. When True, a table of -- True when switch -fdebug-instances is used. When True, a table of
-- instances is included in SCOs. -- instances is included in SCOs.
Generate_Target_Dependent_Info : Boolean := False;
-- GNAT
-- When true (-gnatet switch used). True if target dependent info is to be
-- generated in the ali file.
Generating_Code : Boolean := False; Generating_Code : Boolean := False;
-- GNAT -- GNAT
-- True if the frontend finished its work and has called the backend to -- True if the frontend finished its work and has called the backend to
......
gcc/ada/par-prag.adb
...@@ -1189,7 +1189,8 @@ begin ...@@ -1189,7 +1189,8 @@ begin
Pragma_Lock_Free | Pragma_Lock_Free |
Pragma_Locking_Policy | Pragma_Locking_Policy |
Pragma_Long_Float | Pragma_Long_Float |
Pragma_Loop_Assertion | Pragma_Loop_Invariant |
Pragma_Loop_Variant |
Pragma_Machine_Attribute | Pragma_Machine_Attribute |
Pragma_Main | Pragma_Main |
Pragma_Main_Storage | Pragma_Main_Storage |
......
gcc/ada/sem_attr.adb
...@@ -3795,15 +3795,17 @@ package body Sem_Attr is ...@@ -3795,15 +3795,17 @@ package body Sem_Attr is
Stmt := N; Stmt := N;
while Present (Stmt) loop while Present (Stmt) loop
-- Locate the enclosing Loop_Assertion pragma (if any). Note that -- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if
-- when Loop_Assertion is expanded, we must look for an Assertion -- any). Note that when these two are expanded, we must look for
-- pragma. -- an Assertion pragma.
if Nkind (Original_Node (Stmt)) = N_Pragma if Nkind (Original_Node (Stmt)) = N_Pragma
and then and then
(Pragma_Name (Original_Node (Stmt)) = Name_Assert (Pragma_Name (Original_Node (Stmt)) = Name_Assert
or else or else
Pragma_Name (Original_Node (Stmt)) = Name_Loop_Assertion) Pragma_Name (Original_Node (Stmt)) = Name_Loop_Invariant
or else
Pragma_Name (Original_Node (Stmt)) = Name_Loop_Variant)
then then
In_Loop_Assertion := True; In_Loop_Assertion := True;
......
gcc/ada/sem_prag.adb
...@@ -618,6 +618,10 @@ package body Sem_Prag is ...@@ -618,6 +618,10 @@ package body Sem_Prag is
-- Common processing for first argument of pragma Interrupt_Handler or -- Common processing for first argument of pragma Interrupt_Handler or
-- pragma Attach_Handler. -- pragma Attach_Handler.
procedure Check_Loop_Invariant_Variant_Placement;
-- Verify whether pragma Loop_Invariant or pragma Loop_Variant appear
-- immediately within the statements of the related loop.
procedure Check_Is_In_Decl_Part_Or_Package_Spec; procedure Check_Is_In_Decl_Part_Or_Package_Spec;
-- Check that pragma appears in a declarative part, or in a package -- Check that pragma appears in a declarative part, or in a package
-- specification, i.e. that it does not occur in a statement sequence -- specification, i.e. that it does not occur in a statement sequence
...@@ -1912,6 +1916,44 @@ package body Sem_Prag is ...@@ -1912,6 +1916,44 @@ package body Sem_Prag is
end if; end if;
end Check_Interrupt_Or_Attach_Handler; end Check_Interrupt_Or_Attach_Handler;
--------------------------------------------
-- Check_Loop_Invariant_Variant_Placement --
--------------------------------------------
procedure Check_Loop_Invariant_Variant_Placement is
Loop_Stmt : Node_Id;
begin
-- Locate the enclosing loop statement (if any)
Loop_Stmt := N;
while Present (Loop_Stmt) loop
if Nkind (Loop_Stmt) = N_Loop_Statement then
exit;
-- Prevent the search from going too far
elsif Nkind_In (Loop_Stmt, N_Entry_Body,
N_Package_Body,
N_Package_Declaration,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body)
then
Error_Pragma ("pragma % must appear inside a loop statement");
return;
else
Loop_Stmt := Parent (Loop_Stmt);
end if;
end loop;
if List_Containing (N) /= Statements (Loop_Stmt) then
Error_Pragma
("pragma % must occur immediately in the statements of a loop");
end if;
end Check_Loop_Invariant_Variant_Placement;
------------------------------------------- -------------------------------------------
-- Check_Is_In_Decl_Part_Or_Package_Spec -- -- Check_Is_In_Decl_Part_Or_Package_Spec --
------------------------------------------- -------------------------------------------
...@@ -11453,74 +11495,62 @@ package body Sem_Prag is ...@@ -11453,74 +11495,62 @@ package body Sem_Prag is
end Long_Float; end Long_Float;
-------------------- --------------------
-- Loop_Assertion -- -- Loop_Invariant --
-------------------- --------------------
-- pragma Loop_Assertion -- pragma Loop_Invariant ( boolean_EXPRESSION );
-- ( [Invariant =>] boolean_Expression );
-- | ( [[Invariant =>] boolean_Expression ,]
-- Variant =>
-- ( TERMINATION_VARIANT {, TERMINATION_VARIANT ) );
-- TERMINATION_VARIANT ::= CHANGE_MODIFIER => discrete_EXPRESSION
-- CHANGE_MODIFIER ::= Increasing | Decreasing when Pragma_Loop_Invariant => Loop_Invariant : declare
begin
when Pragma_Loop_Assertion => Loop_Assertion : declare GNAT_Pragma;
procedure Check_Variant (Arg : Node_Id); S14_Pragma;
-- Verify the legality of a variant Check_Arg_Count (1);
Check_Loop_Invariant_Variant_Placement;
-------------------
-- Check_Variant --
-------------------
procedure Check_Variant (Arg : Node_Id) is -- Completely ignore if disabled
Expr : constant Node_Id := Expression (Arg);
begin if Check_Disabled (Pname) then
-- Variants appear in aggregate form Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
return;
end if;
if Nkind (Expr) = N_Aggregate then Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
declare
Comp : Node_Id;
Extra : Node_Id;
Modif : Node_Id;
begin -- Transform pagma Loop_Invariant into an equivalent pragma Check.
Comp := First (Component_Associations (Expr)); -- Generate:
while Present (Comp) loop -- pragma Check (Loop_Invaraint, Arg1);
Modif := First (Choices (Comp));
Extra := Next (Modif);
Check_Arg_Is_One_Of Rewrite (N,
(Modif, Name_Decreasing, Name_Increasing); Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Loop_Invariant)),
Relocate_Node (Arg1))));
if Present (Extra) then Analyze (N);
Error_Pragma_Arg end Loop_Invariant;
("only one modifier allowed in argument", Expr);
end if;
Preanalyze_And_Resolve ------------------
(Expression (Comp), Any_Discrete); -- Loop_Variant --
------------------
Next (Comp); -- pragma Loop_Variant
end loop; -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
end;
else
Error_Pragma_Arg
("expression on variant must be an aggregate", Expr);
end if;
end Check_Variant;
-- Local variables -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
Stmt : Node_Id; -- CHANGE_DIRECTION ::= Increases | Decreases
-- Start of processing for Loop_Assertion when Pragma_Loop_Variant => Loop_Variant : declare
Variant : Node_Id;
begin begin
GNAT_Pragma; GNAT_Pragma;
S14_Pragma; S14_Pragma;
Check_At_Least_N_Arguments (1);
Check_Loop_Invariant_Variant_Placement;
-- Completely ignore if disabled -- Completely ignore if disabled
...@@ -11530,56 +11560,21 @@ package body Sem_Prag is ...@@ -11530,56 +11560,21 @@ package body Sem_Prag is
return; return;
end if; end if;
-- Verify that the pragma appears inside a loop -- Process all increasing / decreasing expressions
Stmt := N;
while Present (Stmt) and then Nkind (Stmt) /= N_Loop_Statement loop
Stmt := Parent (Stmt);
end loop;
if No (Stmt) then
Error_Pragma ("pragma % must appear inside a loop");
end if;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
-- Process the first argument
if Chars (Arg1) = Name_Variant then Variant := First (Pragma_Argument_Associations (N));
Check_Variant (Arg1); while Present (Variant) loop
if Chars (Variant) /= Name_Decreases
elsif Chars (Arg1) = No_Name and then Chars (Variant) /= Name_Increases
or else Chars (Arg1) = Name_Invariant
then then
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean); Error_Pragma_Arg ("wrong change modifier", Variant);
else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg1);
end if; end if;
-- Process the second argument Preanalyze_And_Resolve (Expression (Variant), Any_Discrete);
if Present (Arg2) then Next (Variant);
if Chars (Arg2) = Name_Variant then end loop;
if Chars (Arg1) = Name_Variant then end Loop_Variant;
Error_Pragma ("only one variant allowed in pragma %");
else
Check_Variant (Arg2);
end if;
elsif Chars (Arg2) = Name_Invariant then
if Chars (Arg1) = Name_Variant then
Error_Pragma_Arg ("invariant must precede variant", Arg2);
else
Error_Pragma ("only one invariant allowed in pragma %");
end if;
else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg2);
end if;
end if;
end Loop_Assertion;
----------------------- -----------------------
-- Machine_Attribute -- -- Machine_Attribute --
...@@ -15707,7 +15702,8 @@ package body Sem_Prag is ...@@ -15707,7 +15702,8 @@ package body Sem_Prag is
Pragma_Lock_Free => -1, Pragma_Lock_Free => -1,
Pragma_Locking_Policy => -1, Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1, Pragma_Long_Float => -1,
Pragma_Loop_Assertion => -1, Pragma_Loop_Invariant => -1,
Pragma_Loop_Variant => -1,
Pragma_Machine_Attribute => -1, Pragma_Machine_Attribute => -1,
Pragma_Main => -1, Pragma_Main => -1,
Pragma_Main_Storage => -1, Pragma_Main_Storage => -1,
......
gcc/ada/snames.ads-tmpl
...@@ -405,7 +405,8 @@ package Snames is ...@@ -405,7 +405,8 @@ package Snames is
Name_License : constant Name_Id := N + $; -- GNAT Name_License : constant Name_Id := N + $; -- GNAT
Name_Locking_Policy : constant Name_Id := N + $; Name_Locking_Policy : constant Name_Id := N + $;
Name_Long_Float : constant Name_Id := N + $; -- VMS Name_Long_Float : constant Name_Id := N + $; -- VMS
Name_Loop_Assertion : constant Name_Id := N + $; -- GNAT Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT
Name_Loop_Variant : constant Name_Id := N + $; -- GNAT
Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT
Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT
Name_Normalize_Scalars : constant Name_Id := N + $; Name_Normalize_Scalars : constant Name_Id := N + $;
...@@ -671,7 +672,7 @@ package Snames is ...@@ -671,7 +672,7 @@ package Snames is
Name_Component_Size_4 : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $;
Name_Copy : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $;
Name_D_Float : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $;
Name_Decreasing : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $;
Name_Descriptor : constant Name_Id := N + $; Name_Descriptor : constant Name_Id := N + $;
Name_Disable : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $;
Name_Dot_Replacement : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $;
...@@ -691,7 +692,7 @@ package Snames is ...@@ -691,7 +692,7 @@ package Snames is
Name_GPL : constant Name_Id := N + $; Name_GPL : constant Name_Id := N + $;
Name_IEEE_Float : constant Name_Id := N + $; Name_IEEE_Float : constant Name_Id := N + $;
Name_Ignore : constant Name_Id := N + $; Name_Ignore : constant Name_Id := N + $;
Name_Increasing : constant Name_Id := N + $; Name_Increases : constant Name_Id := N + $;
Name_Info : constant Name_Id := N + $; Name_Info : constant Name_Id := N + $;
Name_Internal : constant Name_Id := N + $; Name_Internal : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $; Name_Link_Name : constant Name_Id := N + $;
...@@ -1686,7 +1687,8 @@ package Snames is ...@@ -1686,7 +1687,8 @@ package Snames is
Pragma_License, Pragma_License,
Pragma_Locking_Policy, Pragma_Locking_Policy,
Pragma_Long_Float, Pragma_Long_Float,
Pragma_Loop_Assertion, Pragma_Loop_Invariant,
Pragma_Loop_Variant,
Pragma_No_Run_Time, Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing, Pragma_No_Strict_Aliasing,
Pragma_Normalize_Scalars, Pragma_Normalize_Scalars,
......
gcc/ada/switch-c.adb
...@@ -614,6 +614,12 @@ package body Switch.C is ...@@ -614,6 +614,12 @@ package body Switch.C is
Generate_SCO := True; Generate_SCO := True;
Ptr := Ptr + 1; Ptr := Ptr + 1;
-- -gnatet (generate target dependent information)
when 't' =>
Generate_Target_Dependent_Info := True;
Ptr := Ptr + 1;
-- -gnateV (validity checks on parameters) -- -gnateV (validity checks on parameters)
when 'V' => when 'V' =>
......
gcc/ada/usage.adb
...@@ -232,6 +232,11 @@ begin ...@@ -232,6 +232,11 @@ begin
Write_Switch_Char ("eS"); Write_Switch_Char ("eS");
Write_Line ("Generate SCO (Source Coverage Obligation) information"); Write_Line ("Generate SCO (Source Coverage Obligation) information");
-- Line for -gnatet switch
Write_Switch_Char ("et");
Write_Line ("Generate target dependent information in ALI file");
-- Line for -gnateV switch -- Line for -gnateV switch
Write_Switch_Char ("eV"); Write_Switch_Char ("eV");
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment