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 364 additions and 242 deletions
gcc/ada/ChangeLog
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,
atree.adb, sem_eval.adb: Minor reformatting.
......
gcc/ada/exp_prag.adb
......@@ -69,7 +69,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (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_Relative_Deadline (N : Node_Id);
......@@ -191,8 +191,8 @@ package body Exp_Prag is
when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N);
when Pragma_Loop_Assertion =>
Expand_Pragma_Loop_Assertion (N);
when Pragma_Loop_Variant =>
Expand_Pragma_Loop_Variant (N);
when Pragma_Psect_Object =>
Expand_Pragma_Psect_Object (N);
......@@ -795,20 +795,19 @@ package body Exp_Prag is
end if;
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
-- for | while ... loop
-- <preceding source statements>
-- pragma Loop_Assertion
-- (Invariant => Invar_Expr,
-- Variant => (Increasing => Incr_Expr,
-- Decreasing => Decr_Expr));
-- pragma Loop_Variant
-- (Increases => Incr_Expr,
-- Decreases => Decr_Expr);
-- <succeeding source statements>
-- end loop;
......@@ -823,8 +822,6 @@ package body Exp_Prag is
-- for | while ... loop
-- <preceding source statements>
-- pragma Assert (<Invar_Expr>);
-- if Flag then
-- Old_1 := Curr_1;
-- Old_2 := Curr_2;
......@@ -846,7 +843,9 @@ package body Exp_Prag is
-- <succeeding source statements>
-- 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);
Curr_Assign : List_Id := No_List;
Flag_Id : Entity_Id := Empty;
......@@ -854,27 +853,23 @@ package body Exp_Prag is
Loop_Scop : Entity_Id;
Loop_Stmt : Node_Id;
Old_Assign : List_Id := No_List;
Variant : Node_Id;
procedure Process_Increase_Decrease
(Variant : Node_Id;
Is_Last : Boolean);
procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
-- Process a single increasing / decreasing termination variant. Flag
-- Is_Last should be set when processing the last variant.
-------------------------------
-- Process_Increase_Decrease --
-------------------------------
---------------------
-- Process_Variant --
---------------------
procedure Process_Increase_Decrease
(Variant : Node_Id;
Is_Last : Boolean)
is
procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
function Make_Op
(Loc : Source_Ptr;
Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id;
-- 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 --
......@@ -885,12 +880,11 @@ package body Exp_Prag is
Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id
is
Modif : constant Node_Id := First (Choices (Variant));
begin
if Chars (Modif) = Name_Increasing then
if Chars (Variant) = Name_Increases then
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);
end if;
end Make_Op;
......@@ -898,13 +892,14 @@ package body Exp_Prag is
-- Local variables
Expr : constant Node_Id := Expression (Variant);
Expr_Typ : constant Entity_Id := Etype (Expr);
Loc : constant Source_Ptr := Sloc (Expr);
Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
Curr_Id : Entity_Id;
Old_Id : Entity_Id;
Prag : Node_Id;
-- Start of processing for Process_Increase_Decrease
-- Start of processing for Process_Variant
begin
-- All temporaries generated in this routine must be inserted before
......@@ -959,8 +954,7 @@ package body Exp_Prag is
Insert_Action (Loop_Stmt,
Make_Object_Declaration (Loop_Loc,
Defining_Identifier => Curr_Id,
Object_Definition =>
New_Reference_To (Etype (Expr), Loop_Loc)));
Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
-- Generate:
-- Old : <type of Expr>;
......@@ -970,8 +964,7 @@ package body Exp_Prag is
Insert_Action (Loop_Stmt,
Make_Object_Declaration (Loop_Loc,
Defining_Identifier => Old_Id,
Object_Definition =>
New_Reference_To (Etype (Expr), Loop_Loc)));
Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
-- Restore original scope after all temporaries have been analyzed
......@@ -1066,12 +1059,7 @@ package body Exp_Prag is
Right_Opnd => New_Reference_To (Old_Id, Loc)),
Then_Statements => New_List (Prag)));
end if;
end Process_Increase_Decrease;
-- Local variables
Arg : Node_Id;
Invar : Node_Id := Empty;
end Process_Variant;
-- Start of processing for Expand_Pragma_Loop_Assertion
......@@ -1093,57 +1081,14 @@ package body Exp_Prag is
Loop_Scop := Entity (Identifier (Loop_Stmt));
-- Process all pragma arguments
Arg := First (Pragma_Argument_Associations (N));
while Present (Arg) loop
-- Termination variants appear as components in an aggregate
-- Create the circuitry which verifies individual variants
if Chars (Arg) = Name_Variant then
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));
Variant := First (Pragma_Argument_Associations (N));
while Present (Variant) loop
Process_Increase_Decrease
(Variant => Variant,
Is_Last => Variant = Last_Var);
Process_Variant (Variant, Is_Last => Variant = Last_Var);
Next (Variant);
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.
-- Generate:
......@@ -1151,18 +1096,14 @@ package body Exp_Prag is
-- <Old_Assign>
-- end if;
if Present (Old_Assign) then
Insert_Action (N,
Make_If_Statement (Loc,
Condition => New_Reference_To (Flag_Id, Loc),
Then_Statements => Old_Assign));
end if;
-- Update the values of all expressions
if Present (Curr_Assign) then
Insert_Actions (N, Curr_Assign);
end if;
-- Add the assertion circuitry to test all changes in expressions.
-- Generate:
......@@ -1172,7 +1113,6 @@ package body Exp_Prag is
-- Flag := True;
-- end if;
if Present (If_Stmt) then
Insert_Action (N,
Make_If_Statement (Loc,
Condition => New_Reference_To (Flag_Id, Loc),
......@@ -1181,13 +1121,12 @@ package body Exp_Prag is
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Flag_Id, Loc),
Expression => New_Reference_To (Standard_True, Loc)))));
end if;
-- Note: the pragma has been completely transformed into a sequence of
-- corresponding declarations and statements. We leave it in the tree
-- for documentation purposes. It will be ignored by the backend.
end Expand_Pragma_Loop_Assertion;
end Expand_Pragma_Loop_Variant;
--------------------------------
-- Expand_Pragma_Psect_Object --
......
gcc/ada/lib-writ.adb
......@@ -49,6 +49,7 @@ with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with System.Case_Util; use System.Case_Util;
......@@ -1440,6 +1441,93 @@ package body Lib.Writ is
Output_Alfa;
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
-- 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
--------------------------
-- 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 --
---------------------------------
-- 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 --
----------------------
-- 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 --
......
gcc/ada/opt.ads
......@@ -658,6 +658,11 @@ package Opt is
-- True when switch -fdebug-instances is used. When True, a table of
-- 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;
-- GNAT
-- True if the frontend finished its work and has called the backend to
......
gcc/ada/par-prag.adb
......@@ -1189,7 +1189,8 @@ begin
Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Loop_Assertion |
Pragma_Loop_Invariant |
Pragma_Loop_Variant |
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
......
gcc/ada/sem_attr.adb
......@@ -3795,15 +3795,17 @@ package body Sem_Attr is
Stmt := N;
while Present (Stmt) loop
-- Locate the enclosing Loop_Assertion pragma (if any). Note that
-- when Loop_Assertion is expanded, we must look for an Assertion
-- pragma.
-- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if
-- any). Note that when these two are expanded, we must look for
-- an Assertion pragma.
if Nkind (Original_Node (Stmt)) = N_Pragma
and then
(Pragma_Name (Original_Node (Stmt)) = Name_Assert
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
In_Loop_Assertion := True;
......
gcc/ada/sem_prag.adb
......@@ -618,6 +618,10 @@ package body Sem_Prag is
-- Common processing for first argument of pragma Interrupt_Handler or
-- 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;
-- Check that pragma appears in a declarative part, or in a package
-- specification, i.e. that it does not occur in a statement sequence
......@@ -1912,6 +1916,44 @@ package body Sem_Prag is
end if;
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 --
-------------------------------------------
......@@ -11453,74 +11495,62 @@ package body Sem_Prag is
end Long_Float;
--------------------
-- Loop_Assertion --
-- Loop_Invariant --
--------------------
-- pragma Loop_Assertion
-- ( [Invariant =>] boolean_Expression );
-- | ( [[Invariant =>] boolean_Expression ,]
-- Variant =>
-- ( TERMINATION_VARIANT {, TERMINATION_VARIANT ) );
-- TERMINATION_VARIANT ::= CHANGE_MODIFIER => discrete_EXPRESSION
-- pragma Loop_Invariant ( boolean_EXPRESSION );
-- CHANGE_MODIFIER ::= Increasing | Decreasing
when Pragma_Loop_Assertion => Loop_Assertion : declare
procedure Check_Variant (Arg : Node_Id);
-- Verify the legality of a variant
-------------------
-- Check_Variant --
-------------------
when Pragma_Loop_Invariant => Loop_Invariant : declare
begin
GNAT_Pragma;
S14_Pragma;
Check_Arg_Count (1);
Check_Loop_Invariant_Variant_Placement;
procedure Check_Variant (Arg : Node_Id) is
Expr : constant Node_Id := Expression (Arg);
-- Completely ignore if disabled
begin
-- Variants appear in aggregate form
if Check_Disabled (Pname) then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
return;
end if;
if Nkind (Expr) = N_Aggregate then
declare
Comp : Node_Id;
Extra : Node_Id;
Modif : Node_Id;
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
begin
Comp := First (Component_Associations (Expr));
while Present (Comp) loop
Modif := First (Choices (Comp));
Extra := Next (Modif);
-- Transform pagma Loop_Invariant into an equivalent pragma Check.
-- Generate:
-- pragma Check (Loop_Invaraint, Arg1);
Check_Arg_Is_One_Of
(Modif, Name_Decreasing, Name_Increasing);
Rewrite (N,
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
Error_Pragma_Arg
("only one modifier allowed in argument", Expr);
end if;
Analyze (N);
end Loop_Invariant;
Preanalyze_And_Resolve
(Expression (Comp), Any_Discrete);
------------------
-- Loop_Variant --
------------------
Next (Comp);
end loop;
end;
else
Error_Pragma_Arg
("expression on variant must be an aggregate", Expr);
end if;
end Check_Variant;
-- pragma Loop_Variant
-- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
-- 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
GNAT_Pragma;
S14_Pragma;
Check_At_Least_N_Arguments (1);
Check_Loop_Invariant_Variant_Placement;
-- Completely ignore if disabled
......@@ -11530,56 +11560,21 @@ package body Sem_Prag is
return;
end if;
-- Verify that the pragma appears inside a loop
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
-- Process all increasing / decreasing expressions
if Chars (Arg1) = Name_Variant then
Check_Variant (Arg1);
elsif Chars (Arg1) = No_Name
or else Chars (Arg1) = Name_Invariant
Variant := First (Pragma_Argument_Associations (N));
while Present (Variant) loop
if Chars (Variant) /= Name_Decreases
and then Chars (Variant) /= Name_Increases
then
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg1);
Error_Pragma_Arg ("wrong change modifier", Variant);
end if;
-- Process the second argument
Preanalyze_And_Resolve (Expression (Variant), Any_Discrete);
if Present (Arg2) then
if Chars (Arg2) = Name_Variant then
if Chars (Arg1) = Name_Variant then
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;
Next (Variant);
end loop;
end Loop_Variant;
-----------------------
-- Machine_Attribute --
......@@ -15707,7 +15702,8 @@ package body Sem_Prag is
Pragma_Lock_Free => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Loop_Assertion => -1,
Pragma_Loop_Invariant => -1,
Pragma_Loop_Variant => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
......
gcc/ada/snames.ads-tmpl
......@@ -405,7 +405,8 @@ package Snames is
Name_License : constant Name_Id := N + $; -- GNAT
Name_Locking_Policy : constant Name_Id := N + $;
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_Strict_Aliasing : constant Name_Id := N + $; -- GNAT
Name_Normalize_Scalars : constant Name_Id := N + $;
......@@ -671,7 +672,7 @@ package Snames is
Name_Component_Size_4 : constant Name_Id := N + $;
Name_Copy : 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_Disable : constant Name_Id := N + $;
Name_Dot_Replacement : constant Name_Id := N + $;
......@@ -691,7 +692,7 @@ package Snames is
Name_GPL : constant Name_Id := N + $;
Name_IEEE_Float : 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_Internal : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $;
......@@ -1686,7 +1687,8 @@ package Snames is
Pragma_License,
Pragma_Locking_Policy,
Pragma_Long_Float,
Pragma_Loop_Assertion,
Pragma_Loop_Invariant,
Pragma_Loop_Variant,
Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing,
Pragma_Normalize_Scalars,
......
gcc/ada/switch-c.adb
......@@ -614,6 +614,12 @@ package body Switch.C is
Generate_SCO := True;
Ptr := Ptr + 1;
-- -gnatet (generate target dependent information)
when 't' =>
Generate_Target_Dependent_Info := True;
Ptr := Ptr + 1;
-- -gnateV (validity checks on parameters)
when 'V' =>
......
gcc/ada/ttypes.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
......@@ -38,11 +38,10 @@ package Ttypes is
-- types on the host and types on the target, since in the general
-- case of a cross-compiler these will be different.
-- This package and its companion Ttypef provide definitions of values
-- that describe the properties of the target types. All instances of
-- target dependencies, including the definitions of such packages as
-- Standard and System depend directly or indirectly on the definitions
-- in the Ttypes and Ttypef packages.
-- This package provides definitions of values that describe the properties
-- of the target types. All instances of target dependencies, including the
-- definitions of such packages as Standard and System depend directly or
-- indirectly on the definitions in the Ttypes packages.
-- In the source of the compiler, references to attributes such as
-- Integer'Size will give information regarding the host types (i.e.
......@@ -93,6 +92,18 @@ package Ttypes is
-- than referencing System.Storage_Unit, or Standard'Storage_Unit, both of
-- which would yield the host value.
----------------------------------------------
-- Target-Dependent Information in ALI File --
----------------------------------------------
-- If the flag Generate_Target_Dependent_Info is set (e.g. by use of the
-- -gnatT switch), then the ALI file contains T lines representing each of
-- the constants defined in this package (see Lib-Writ spec for details).
-- These T lines use a code consisting of four upper case letters to
-- identify the constant whose value is output. These four letter codes
-- may be found as a comment in the declaration of each constant.
---------------------------------------------------
-- Target-Dependent Values for Types in Standard --
---------------------------------------------------
......@@ -102,55 +113,65 @@ package Ttypes is
-- example, on some machines, Short_Float may be the same as Float, and
-- Long_Long_Float may be the same as Long_Float.
Standard_Short_Short_Integer_Size : constant Pos := Get_Char_Size;
Standard_Short_Short_Integer_Width : constant Pos :=
Standard_Short_Short_Integer_Size : constant Pos := -- SINS
Get_Char_Size;
Standard_Short_Short_Integer_Width : constant Pos := -- SINW
Width_From_Size
(Standard_Short_Short_Integer_Size);
Standard_Short_Integer_Size : constant Pos := Get_Short_Size;
Standard_Short_Integer_Width : constant Pos :=
Standard_Short_Integer_Size : constant Pos := -- SHIS
Get_Short_Size;
Standard_Short_Integer_Width : constant Pos := -- SHIW
Width_From_Size
(Standard_Short_Integer_Size);
Standard_Integer_Size : constant Pos := Get_Int_Size;
Standard_Integer_Width : constant Pos :=
Standard_Integer_Size : constant Pos := -- INTS
Get_Int_Size;
Standard_Integer_Width : constant Pos := -- INTW
Width_From_Size
(Standard_Integer_Size);
Standard_Long_Integer_Size : constant Pos := Get_Long_Size;
Standard_Long_Integer_Width : constant Pos :=
Standard_Long_Integer_Size : constant Pos := -- LINS
Get_Long_Size;
Standard_Long_Integer_Width : constant Pos := -- LINW
Width_From_Size
(Standard_Long_Integer_Size);
Standard_Long_Long_Integer_Size : constant Pos := Get_Long_Long_Size;
Standard_Long_Long_Integer_Width : constant Pos :=
Standard_Long_Long_Integer_Size : constant Pos := -- LLIS
Get_Long_Long_Size;
Standard_Long_Long_Integer_Width : constant Pos := -- LLIW
Width_From_Size
(Standard_Long_Long_Integer_Size);
Standard_Short_Float_Size : constant Pos := Get_Float_Size;
Standard_Short_Float_Digits : constant Pos :=
Standard_Short_Float_Size : constant Pos := -- SFLS
Get_Float_Size;
Standard_Short_Float_Digits : constant Pos := -- SFLD
Digits_From_Size
(Standard_Short_Float_Size);
Standard_Float_Size : constant Pos := Get_Float_Size;
Standard_Float_Digits : constant Pos :=
Standard_Float_Size : constant Pos := -- FLTS
Get_Float_Size;
Standard_Float_Digits : constant Pos := -- FLTD
Digits_From_Size
(Standard_Float_Size);
Standard_Long_Float_Size : constant Pos := Get_Double_Size;
Standard_Long_Float_Digits : constant Pos :=
Standard_Long_Float_Size : constant Pos := -- LFLS
Get_Double_Size;
Standard_Long_Float_Digits : constant Pos := -- LFLD
Digits_From_Size
(Standard_Long_Float_Size);
Standard_Long_Long_Float_Size : constant Pos := Get_Long_Double_Size;
Standard_Long_Long_Float_Digits : constant Pos :=
Standard_Long_Long_Float_Size : constant Pos := -- LLFS
Get_Long_Double_Size;
Standard_Long_Long_Float_Digits : constant Pos := -- LLFD
Digits_From_Size
(Standard_Long_Long_Float_Size);
Standard_Character_Size : constant Pos := Get_Char_Size;
Standard_Character_Size : constant Pos := -- CHAS
Get_Char_Size;
Standard_Wide_Character_Size : constant Pos := 16;
Standard_Wide_Wide_Character_Size : constant Pos := 32;
Standard_Wide_Character_Size : constant Pos := 16; -- WCHS
Standard_Wide_Wide_Character_Size : constant Pos := 32; -- WWCS
-- Standard wide character sizes
-- Note: there is no specific control over the representation of
......@@ -166,18 +187,19 @@ package Ttypes is
-- Target-Dependent Values for Types in System --
-------------------------------------------------
System_Address_Size : constant Pos := Get_Pointer_Size;
System_Address_Size : constant Pos := Get_Pointer_Size; -- ADRS
-- System.Address'Size (also size of all thin pointers)
System_Max_Binary_Modulus_Power : constant Pos :=
System_Max_Binary_Modulus_Power : constant Pos := -- MBMP
Standard_Long_Long_Integer_Size;
System_Max_Nonbinary_Modulus_Power : constant Pos := Standard_Integer_Size;
System_Max_Nonbinary_Modulus_Power : constant Pos := -- MNMP
Standard_Integer_Size;
System_Storage_Unit : constant Pos := Get_Bits_Per_Unit;
System_Word_Size : constant Pos := Get_Bits_Per_Word;
System_Storage_Unit : constant Pos := Get_Bits_Per_Unit; -- SUNI
System_Word_Size : constant Pos := Get_Bits_Per_Word; -- WRDS
System_Tick_Nanoseconds : constant Pos := 1_000_000_000;
System_Tick_Nanoseconds : constant Pos := 1_000_000_000; -- TICK
-- Value of System.Tick in nanoseconds. At the moment, this is a fixed
-- constant (with value of 1.0 seconds), but later we should add this
-- value to the GCC configuration file so that its value can be made
......@@ -187,25 +209,25 @@ package Ttypes is
-- Target-Dependent Values for Types in Interfaces --
-----------------------------------------------------
Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size;
Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size; -- WCTS
----------------------------------------
-- Other Target-Dependent Definitions --
----------------------------------------
Maximum_Alignment : constant Pos := Get_Maximum_Alignment;
Maximum_Alignment : constant Pos := Get_Maximum_Alignment; -- MAXA
-- The maximum alignment, in storage units, that an object or type may
-- require on the target machine.
System_Allocator_Alignment : constant Pos :=
System_Allocator_Alignment : constant Pos := -- ALLA
Get_System_Allocator_Alignment;
-- The alignment in storage units of addresses returned by malloc
Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field;
Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field; -- MUNF
-- The maximum supported size in bits for a field that is not aligned
-- on a storage unit boundary.
Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0;
Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0; -- BEND
-- Important note: for Ada purposes, the important setting is the bytes
-- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian).
-- This is because Ada bit addressing must be compatible with the byte
......@@ -215,15 +237,20 @@ package Ttypes is
-- and thus relevant only to the back end. Note that this is a variable
-- rather than a constant, since it can be modified (flipped) by -gnatd8.
Target_Strict_Alignment : Boolean := Get_Strict_Alignment /= 0;
-- True if instructions will fail if data is misaligned
Target_Strict_Alignment : Boolean := -- STRA
Get_Strict_Alignment /= 0;
-- True if instructions will fail if data is misaligned. Note that this
-- is a variable rather than a constant since it can be modified (set to
-- True) if the debug flag -gnatd.A is used.
Target_Double_Float_Alignment : Nat := Get_Double_Float_Alignment;
Target_Double_Float_Alignment : constant Nat := -- DFLA
Get_Double_Float_Alignment;
-- The default alignment of "double" floating-point types, i.e. floating
-- point types whose size is equal to 64 bits, or 0 if this alignment is
-- not specifically capped.
Target_Double_Scalar_Alignment : Nat := Get_Double_Scalar_Alignment;
Target_Double_Scalar_Alignment : constant Nat := -- DSCA
Get_Double_Scalar_Alignment;
-- The default alignment of "double" or larger scalar types, i.e. scalar
-- types whose size is greater or equal to 64 bits, or 0 if this alignment
-- is not specifically capped.
......
gcc/ada/usage.adb
......@@ -232,6 +232,11 @@ begin
Write_Switch_Char ("eS");
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
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