Skip to content

R
riscv-gcc-1
Commit 752b81d9 by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Arnaud Charlet  <charlet@adacore.com>

	* xgnatugn.adb: Remove obsolete comments.

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* back_end.ads, back_end.adb: Minor reformatting.
	* set_targ.ads, set_targ.adb: New files.

2013-04-11  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_case.adb (Check_Against_Predicate): New routine.
	(Check_Choices): When the type covered by the list of choices
	is a static subtype with a static predicate, check all choices
	agains the predicate.
	(Issue_Msg): All versions removed.
	(Missing_Choice): New routines.
	* sem_ch4.adb: Code and comment reformatting.
	(Analyze_Case_Expression): Do not check the choices when the case
	expression is being preanalyzed and the type of the expression
	is a subtype with a static predicate.
	(Has_Static_Predicate): New routine.
	* sem_ch13.adb: Code and comment reformatting.	(Build_Range):
	Always build a range even if the low and hi bounds denote the
	same value. This is needed by the machinery in Check_Choices.
	(Build_Static_Predicate): Always build a range even if the low and
	hi bounds denote the same value. This is needed by the machinery
	in Check_Choices.

From-SVN: r197789
parent 4b342b91
Showing with 1631 additions and 216 deletions
gcc/ada/ChangeLog
2013-04-11 Arnaud Charlet <charlet@adacore.com>
* xgnatugn.adb: Remove obsolete comments.
2013-04-11 Robert Dewar <dewar@adacore.com>
* back_end.ads, back_end.adb: Minor reformatting.
* set_targ.ads, set_targ.adb: New files.
2013-04-11 Hristian Kirtchev <kirtchev@adacore.com>
* sem_case.adb (Check_Against_Predicate): New routine.
(Check_Choices): When the type covered by the list of choices
is a static subtype with a static predicate, check all choices
agains the predicate.
(Issue_Msg): All versions removed.
(Missing_Choice): New routines.
* sem_ch4.adb: Code and comment reformatting.
(Analyze_Case_Expression): Do not check the choices when the case
expression is being preanalyzed and the type of the expression
is a subtype with a static predicate.
(Has_Static_Predicate): New routine.
* sem_ch13.adb: Code and comment reformatting. (Build_Range):
Always build a range even if the low and hi bounds denote the
same value. This is needed by the machinery in Check_Choices.
(Build_Static_Predicate): Always build a range even if the low and
hi bounds denote the same value. This is needed by the machinery
in Check_Choices.
2013-04-11 Robert Dewar <dewar@adacore.com>
* einfo.ads, sem_util.adb, exp_ch6.adb, xgnatugn.adb: Minor
......
gcc/ada/back_end.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
......@@ -347,7 +347,6 @@ package body Back_End is
procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is
procedure Enumerate_Modes (Call_Back : Register_Type_Proc);
pragma Import (C, Enumerate_Modes, "enumerate_modes");
begin
Enumerate_Modes (Call_Back);
end Register_Back_End_Types;
......
gcc/ada/back_end.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
......@@ -24,7 +24,8 @@
------------------------------------------------------------------------------
-- Call the back end with all the information needed. Also contains other
-- back-end specific interfaces required by the front end.
-- back-end specific interfaces required by the front end. See also Get_Targ,
-- which defines additional interfaces to the back end.
with Einfo; use Einfo;
......@@ -63,13 +64,13 @@ package Back_End is
-- the back end.
procedure Register_Back_End_Types (Call_Back : Register_Type_Proc);
-- Calls the Call_Back function with information for each supported type.
-- Calls the Call_Back function with information for each supported type
procedure Call_Back_End (Mode : Back_End_Mode_Type);
-- Call back end, i.e. make call to driver traversing the tree and
-- outputting code. This call is made with all tables locked.
-- The back end is responsible for unlocking any tables it may need
-- to change, and locking them again before returning.
-- outputting code. This call is made with all tables locked. The back
-- end is responsible for unlocking any tables it may need to change,
-- and locking them again before returning.
procedure Scan_Compiler_Arguments;
-- Acquires command-line parameters passed to the compiler and processes
......
gcc/ada/sem_case.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2013, 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- --
......@@ -114,6 +114,18 @@ package body Sem_Case is
Others_Present : Boolean;
Case_Node : Node_Id)
is
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
Prev_Lo : in out Uint;
Prev_Hi : in out Uint;
Error : in out Boolean);
-- Determine whether a choice covers legal values as defined by a static
-- predicate set. Pred is a static predicate range. Choice is the choice
-- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
-- choice that covered a predicate set. Error denotes whether the check
-- found an illegal intersection.
procedure Explain_Non_Static_Bound;
-- Called when we find a non-static bound, requiring the base type to
-- be covered. Provides where possible a helpful explanation of why the
......@@ -123,102 +135,292 @@ package body Sem_Case is
-- Comparison routine for comparing Choice_Table entries. Use the lower
-- bound of each Choice as the key.
procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id);
procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint);
procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id);
procedure Missing_Choice (Value1 : Uint; Value2 : Uint);
-- Issue an error message indicating that there are missing choices,
-- followed by the image of the missing choices themselves which lie
-- between Value1 and Value2 inclusive.
procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
-- Emit an error message for each non-covered static predicate set.
-- Prev_Hi denotes the upper bound of the last choice that covered a
-- set.
procedure Move_Choice (From : Natural; To : Natural);
-- Move routine for sorting the Choice_Table
package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Uint; Value2 : Uint);
-- Issue an error message indicating that there are missing choices,
-- followed by the image of the missing choices themselves which lie
-- between Value1 and Value2 inclusive.
-----------------------------
-- Check_Against_Predicate --
-----------------------------
---------------
-- Issue_Msg --
---------------
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
Prev_Lo : in out Uint;
Prev_Hi : in out Uint;
Error : in out Boolean)
is
procedure Illegal_Range
(Loc : Source_Ptr;
Lo : Uint;
Hi : Uint);
-- Emit an error message regarding a choice that clashes with the
-- legal static predicate sets. Loc is the location of the choice
-- that introduced the illegal range. Lo .. Hi is the range.
function Inside_Range
(Lo : Uint;
Hi : Uint;
Val : Uint) return Boolean;
-- Determine whether position Val within a discrete type is within
-- the range Lo .. Hi inclusive.
-------------------
-- Illegal_Range --
-------------------
procedure Illegal_Range
(Loc : Source_Ptr;
Lo : Uint;
Hi : Uint)
is
begin
Error_Msg_Name_1 := Chars (Bounds_Type);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
begin
Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
end Issue_Msg;
-- Single value
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
begin
Issue_Msg (Expr_Value (Value1), Value2);
end Issue_Msg;
if Lo = Hi then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg ("static predicate on % excludes value ^!", Loc);
else
Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
Error_Msg ("static predicate on % excludes value %!", Loc);
end if;
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
begin
Issue_Msg (Value1, Expr_Value (Value2));
end Issue_Msg;
-- Range
procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi;
Error_Msg
("static predicate on % excludes range ^ .. ^!", Loc);
else
Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type);
Error_Msg
("static predicate on % excludes range % .. %!", Loc);
end if;
end if;
end Illegal_Range;
------------------
-- Inside_Range --
------------------
function Inside_Range
(Lo : Uint;
Hi : Uint;
Val : Uint) return Boolean
is
begin
return
Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
end Inside_Range;
-- Local variables
Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
Loc : Source_Ptr;
Next_Hi : Uint;
Next_Lo : Uint;
Pred_Hi : Uint;
Pred_Lo : Uint;
-- Start of processing for Check_Against_Predicate
begin
-- AI05-0188 : within an instance the non-others choices do not
-- have to belong to the actual subtype.
-- Find the proper error message location
if Ada_Version >= Ada_2012 and then In_Instance then
return;
if Present (Choice.Node) then
Loc := Sloc (Choice.Node);
else
Loc := Sloc (Case_Node);
end if;
-- In some situations, we call this with a null range, and
-- obviously we don't want to complain in this case!
if Present (Pred) then
Pred_Lo := Expr_Value (Low_Bound (Pred));
Pred_Hi := Expr_Value (High_Bound (Pred));
-- Previous choices managed to satisfy all static predicate sets
else
Illegal_Range (Loc, Choice_Lo, Choice_Hi);
Error := True;
if Value1 > Value2 then
return;
end if;
-- Case of only one value that is missing
-- Step 1: Detect duplicate choices
if Value1 = Value2 then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg ("missing case value: ^!", Msg_Sloc);
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
then
Error_Msg ("duplication of choice value", Loc);
Error := True;
-- Step 2: Detect full coverage
-- Choice_Lo Choice_Hi
-- +============+
-- Pred_Lo Pred_Hi
elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then
Prev_Lo := Choice_Lo;
Prev_Hi := Choice_Hi;
Next (Pred);
-- Step 3: Detect all cases where a choice mentions values that are
-- not part of the static predicate sets.
-- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
-- +-----------+ . . . . . +=========+
-- ^ illegal ^
elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then
Illegal_Range (Loc, Choice_Lo, Choice_Hi);
Error := True;
-- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
-- +-----------+=========+===========+
-- ^ illegal ^
elsif Choice_Lo < Pred_Lo
and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi)
then
Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
Error := True;
-- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
-- +=========+ . . . . +-----------+
-- ^ illegal ^
elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then
Missing_Choice (Pred_Lo, Pred_Hi);
Error := True;
-- There may be several static predicate sets between the current
-- one and the choice. Inspect the next static predicate set.
Next (Pred);
Check_Against_Predicate
(Pred => Pred,
Choice => Choice,
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
-- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
-- +=========+===========+-----------+
-- ^ illegal ^
elsif Pred_Hi < Choice_Hi
and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo)
then
Next (Pred);
-- The choice may fall in a static predicate set. If this is the
-- case, avoid mentioning legal values in the error message.
if Present (Pred) then
Next_Lo := Expr_Value (Low_Bound (Pred));
Next_Hi := Expr_Value (High_Bound (Pred));
-- The next static predicate set is to the right of the choice
if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then
Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
else
Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1);
end if;
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg ("missing case value: %!", Msg_Sloc);
Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
end if;
-- More than one choice value, so print range of values
Error := True;
-- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
-- +-----------+=========+-----------+
-- ^ illegal ^ ^ illegal ^
-- Emit an error on the low gap, disregard the upper gap
elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then
Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
Error := True;
-- Step 4: Detect all cases of partial or missing coverage
-- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
-- +=========+==========+===========+
-- ^ gap ^ ^ gap ^
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg_Uint_2 := Value2;
Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
Error_Msg ("missing case values: % .. %!", Msg_Sloc);
end if;
end if;
end Issue_Msg;
-- An "others" choice covers all gaps
---------------
-- Lt_Choice --
---------------
if Others_Present then
Prev_Lo := Choice_Lo;
Prev_Hi := Choice_Hi;
Next (Pred);
function Lt_Choice (C1, C2 : Natural) return Boolean is
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
<
Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
-- Choice_Lo Choice_Hi Pred_Hi
-- +===========+===========+
-- Pred_Lo ^ gap ^
-----------------
-- Move_Choice --
-----------------
-- The upper gap may be covered by a subsequent choice
procedure Move_Choice (From : Natural; To : Natural) is
begin
Choice_Table (Nat (To)) := Choice_Table (Nat (From));
end Move_Choice;
elsif Pred_Lo = Choice_Lo then
Prev_Lo := Choice_Lo;
Prev_Hi := Choice_Hi;
-- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
-- +===========+=========+===========+===========+
-- ^ covered ^ ^ gap ^
else pragma Assert (Pred_Lo < Choice_Lo);
-- A previous choice covered the gap up to the current choice
if Prev_Hi = Choice_Lo - 1 then
Prev_Lo := Choice_Lo;
Prev_Hi := Choice_Hi;
if Choice_Hi = Pred_Hi then
Next (Pred);
end if;
-- The previous choice did not intersect with the current
-- static predicate set.
elsif Prev_Hi < Pred_Lo then
Missing_Choice (Pred_Lo, Choice_Lo - 1);
Error := True;
-- The previous choice covered part of the static predicate set
else
Missing_Choice (Prev_Hi, Choice_Lo - 1);
Error := True;
end if;
end if;
end if;
end Check_Against_Predicate;
------------------------------
-- Explain_Non_Static_Bound --
......@@ -236,16 +438,16 @@ package body Sem_Case is
if Bounds_Type /= Subtyp then
-- If the case is a variant part, the expression is given by
-- the discriminant itself, and the bounds are the culprits.
-- If the case is a variant part, the expression is given by the
-- discriminant itself, and the bounds are the culprits.
if Nkind (Case_Node) = N_Variant_Part then
Error_Msg_NE
("bounds of & are not static," &
" alternatives must cover base type", Expr, Expr);
-- If this is a case statement, the expression may be
-- non-static or else the subtype may be at fault.
-- If this is a case statement, the expression may be non-static
-- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
Error_Msg_NE
......@@ -269,30 +471,150 @@ package body Sem_Case is
end if;
end Explain_Non_Static_Bound;
-- Variables local to Check_Choices
---------------
-- Lt_Choice --
---------------
function Lt_Choice (C1, C2 : Natural) return Boolean is
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
<
Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
--------------------
-- Missing_Choice --
--------------------
Choice : Node_Id;
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is
begin
Missing_Choice (Expr_Value (Value1), Expr_Value (Value2));
end Missing_Choice;
Prev_Choice : Node_Id;
procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is
begin
Missing_Choice (Expr_Value (Value1), Value2);
end Missing_Choice;
procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is
begin
Missing_Choice (Value1, Expr_Value (Value2));
end Missing_Choice;
procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
begin
-- AI05-0188 : within an instance the non-others choices do not have
-- to belong to the actual subtype.
if Ada_Version >= Ada_2012 and then In_Instance then
return;
-- In some situations, we call this with a null range, and obviously
-- we don't want to complain in this case.
elsif Value1 > Value2 then
return;
end if;
-- Case of only one value that is missing
if Value1 = Value2 then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg ("missing case value: ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg ("missing case value: %!", Msg_Sloc);
end if;
-- More than one choice value, so print range of values
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg_Uint_2 := Value2;
Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
Error_Msg ("missing case values: % .. %!", Msg_Sloc);
end if;
end if;
end Missing_Choice;
---------------------
-- Missing_Choices --
---------------------
Hi : Uint;
Lo : Uint;
Prev_Hi : Uint;
procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is
Hi : Uint;
Lo : Uint;
Set : Node_Id;
begin
Set := Pred;
while Present (Set) loop
Lo := Expr_Value (Low_Bound (Set));
Hi := Expr_Value (High_Bound (Set));
-- A choice covered part of a static predicate set
if Lo <= Prev_Hi and then Prev_Hi < Hi then
Missing_Choice (Prev_Hi + 1, Hi);
else
Missing_Choice (Lo, Hi);
end if;
Next (Set);
end loop;
end Missing_Choices;
-----------------
-- Move_Choice --
-----------------
procedure Move_Choice (From : Natural; To : Natural) is
begin
Choice_Table (Nat (To)) := Choice_Table (Nat (From));
end Move_Choice;
-- Local variables
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Has_Predicate : constant Boolean :=
Is_Static_Subtype (Bounds_Type)
and then Present (Static_Predicate (Bounds_Type));
Num_Choices : constant Nat := Choice_Table'Last;
Choice : Node_Id;
Choice_Hi : Uint;
Choice_Lo : Uint;
Error : Boolean;
Pred : Node_Id;
Prev_Choice : Node_Id;
Prev_Lo : Uint;
Prev_Hi : Uint;
-- Start of processing for Check_Choices
begin
-- Choice_Table must start at 0 which is an unused location used
-- by the sorting algorithm. However the first valid position for
-- a discrete choice is 1.
-- Choice_Table must start at 0 which is an unused location used by the
-- sorting algorithm. However the first valid position for a discrete
-- choice is 1.
pragma Assert (Choice_Table'First = 0);
if Choice_Table'Last = 0 then
-- The choices do not cover the base range. Emit an error if "others" is
-- not available and return as there is no need for further processing.
if Num_Choices = 0 then
if not Others_Present then
Issue_Msg (Bounds_Lo, Bounds_Hi);
Missing_Choice (Bounds_Lo, Bounds_Hi);
end if;
return;
......@@ -300,59 +622,98 @@ package body Sem_Case is
Sorting.Sort (Positive (Choice_Table'Last));
Lo := Expr_Value (Choice_Table (1).Lo);
Hi := Expr_Value (Choice_Table (1).Hi);
Prev_Hi := Hi;
-- The type covered by the list of choices is actually a static subtype
-- subject to a static predicate. The predicate defines subsets of legal
-- values and requires finer grained analysis.
if Has_Predicate then
Pred := First (Static_Predicate (Bounds_Type));
Prev_Lo := Uint_Minus_1;
Prev_Hi := Uint_Minus_1;
Error := False;
for Index in 1 .. Num_Choices loop
Check_Against_Predicate
(Pred => Pred,
Choice => Choice_Table (Index),
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
-- The analysis detected an illegal intersection between a choice
-- and a static predicate set.
if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
Issue_Msg (Bounds_Lo, Lo - 1);
if Error then
return;
end if;
end loop;
-- If values are missing outside of the subtype, add explanation.
-- No additional message if only one value is missing.
-- The choices may legally cover some of the static predicate sets,
-- but not all. Emit an error for each non-covered set.
if Expr_Value (Bounds_Lo) < Lo - 1 then
Explain_Non_Static_Bound;
if not Others_Present then
Missing_Choices (Pred, Prev_Hi);
end if;
end if;
for J in 2 .. Choice_Table'Last loop
Lo := Expr_Value (Choice_Table (J).Lo);
Hi := Expr_Value (Choice_Table (J).Hi);
-- Default analysis
if Lo <= Prev_Hi then
Choice := Choice_Table (J).Node;
else
Choice_Lo := Expr_Value (Choice_Table (1).Lo);
Choice_Hi := Expr_Value (Choice_Table (1).Hi);
Prev_Hi := Choice_Hi;
-- Find first previous choice that overlaps
if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
Missing_Choice (Bounds_Lo, Choice_Lo - 1);
for K in 1 .. J - 1 loop
if Lo <= Expr_Value (Choice_Table (K).Hi) then
Prev_Choice := Choice_Table (K).Node;
exit;
end if;
end loop;
-- If values are missing outside of the subtype, add explanation.
-- No additional message if only one value is missing.
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Error_Msg_N ("duplication of choice value#", Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Error_Msg_N ("duplication of choice value#", Prev_Choice);
if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
Explain_Non_Static_Bound;
end if;
elsif not Others_Present and then Lo /= Prev_Hi + 1 then
Issue_Msg (Prev_Hi + 1, Lo - 1);
end if;
if Hi > Prev_Hi then
Prev_Hi := Hi;
end if;
end loop;
for Outer_Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
if Choice_Lo <= Prev_Hi then
Choice := Choice_Table (Outer_Index).Node;
if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
Issue_Msg (Hi + 1, Bounds_Hi);
-- Find first previous choice that overlaps
if Expr_Value (Bounds_Hi) > Hi + 1 then
Explain_Non_Static_Bound;
for Inner_Index in 1 .. Outer_Index - 1 loop
if Choice_Lo <=
Expr_Value (Choice_Table (Inner_Index).Hi)
then
Prev_Choice := Choice_Table (Inner_Index).Node;
exit;
end if;
end loop;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Error_Msg_N ("duplication of choice value#", Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Error_Msg_N ("duplication of choice value#", Prev_Choice);
end if;
elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
end if;
if Choice_Hi > Prev_Hi then
Prev_Hi := Choice_Hi;
end if;
end loop;
if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then
Missing_Choice (Choice_Hi + 1, Bounds_Hi);
if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then
Explain_Non_Static_Bound;
end if;
end if;
end if;
end Check_Choices;
......
gcc/ada/sem_ch13.adb
......@@ -93,7 +93,7 @@ package body Sem_Ch13 is
-- the function is inserted before the freeze node, and the body of the
-- function is inserted after the freeze node. If the predicate expression
-- has at least one Raise_Expression, then this procedure also builds the
-- M version of the predicate function for ue in membership tests.
-- M version of the predicate function for use in membership tests.
procedure Build_Static_Predicate
(Typ : Entity_Id;
......@@ -6188,15 +6188,15 @@ package body Sem_Ch13 is
type REnt is record
Lo, Hi : Uint;
end record;
-- One entry in a Rlist value, a single REnt (range entry) value
-- denotes one range from Lo to Hi. To represent a single value
-- range Lo = Hi = value.
-- One entry in a Rlist value, a single REnt (range entry) value denotes
-- one range from Lo to Hi. To represent a single value range Lo = Hi =
-- value.
type RList is array (Nat range <>) of REnt;
-- A list of ranges. The ranges are sorted in increasing order,
-- and are disjoint (there is a gap of at least one value between
-- each range in the table). A value is in the set of ranges in
-- Rlist if it lies within one of these ranges
-- A list of ranges. The ranges are sorted in increasing order, and are
-- disjoint (there is a gap of at least one value between each range in
-- the table). A value is in the set of ranges in Rlist if it lies
-- within one of these ranges.
False_Range : constant RList :=
RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
......@@ -6210,41 +6210,41 @@ package body Sem_Ch13 is
True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
-- Range representing True, value must be in the base range
function "and" (Left, Right : RList) return RList;
-- And's together two range lists, returning a range list. This is
-- a set intersection operation.
function "and" (Left : RList; Right : RList) return RList;
-- And's together two range lists, returning a range list. This is a set
-- intersection operation.
function "or" (Left, Right : RList) return RList;
-- Or's together two range lists, returning a range list. This is a
-- set union operation.
function "or" (Left : RList; Right : RList) return RList;
-- Or's together two range lists, returning a range list. This is a set
-- union operation.
function "not" (Right : RList) return RList;
-- Returns complement of a given range list, i.e. a range list
-- representing all the values in TLo .. THi that are not in the
-- input operand Right.
-- representing all the values in TLo .. THi that are not in the input
-- operand Right.
function Build_Val (V : Uint) return Node_Id;
-- Return an analyzed N_Identifier node referencing this value, suitable
-- for use as an entry in the Static_Predicate list. This node is typed
-- with the base type.
function Build_Range (Lo, Hi : Uint) return Node_Id;
-- Return an analyzed N_Range node referencing this range, suitable
-- for use as an entry in the Static_Predicate list. This node is typed
-- with the base type.
function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
-- Return an analyzed N_Range node referencing this range, suitable for
-- use as an entry in the Static_Predicate list. This node is typed with
-- the base type.
function Get_RList (Exp : Node_Id) return RList;
-- This is a recursive routine that converts the given expression into
-- a list of ranges, suitable for use in building the static predicate.
-- This is a recursive routine that converts the given expression into a
-- list of ranges, suitable for use in building the static predicate.
function Is_False (R : RList) return Boolean;
pragma Inline (Is_False);
-- Returns True if the given range list is empty, and thus represents
-- a False list of ranges that can never be satisfied.
-- Returns True if the given range list is empty, and thus represents a
-- False list of ranges that can never be satisfied.
function Is_True (R : RList) return Boolean;
-- Returns True if R trivially represents the True predicate by having
-- a single range from BLo to BHi.
-- Returns True if R trivially represents the True predicate by having a
-- single range from BLo to BHi.
function Is_Type_Ref (N : Node_Id) return Boolean;
pragma Inline (Is_Type_Ref);
......@@ -6277,7 +6277,7 @@ package body Sem_Ch13 is
-- "and" --
-----------
function "and" (Left, Right : RList) return RList is
function "and" (Left : RList; Right : RList) return RList is
FEnt : REnt;
-- First range of result
......@@ -6302,8 +6302,8 @@ package body Sem_Ch13 is
return False_Range;
end if;
-- Loop to remove entries at start that are disjoint, and thus
-- just get discarded from the result entirely.
-- Loop to remove entries at start that are disjoint, and thus just
-- get discarded from the result entirely.
loop
-- If no operands left in either operand, result is false
......@@ -6328,15 +6328,15 @@ package body Sem_Ch13 is
end if;
end loop;
-- Now we have two non-null operands, and first entries overlap.
-- The first entry in the result will be the overlapping part of
-- these two entries.
-- Now we have two non-null operands, and first entries overlap. The
-- first entry in the result will be the overlapping part of these
-- two entries.
FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
-- Now we can remove the entry that ended at a lower value, since
-- its contribution is entirely contained in Fent.
-- Now we can remove the entry that ended at a lower value, since its
-- contribution is entirely contained in Fent.
if Left (SLeft).Hi <= Right (SRight).Hi then
SLeft := SLeft + 1;
......@@ -6344,10 +6344,10 @@ package body Sem_Ch13 is
SRight := SRight + 1;
end if;
-- Compute result by concatenating this first entry with the "and"
-- of the remaining parts of the left and right operands. Note that
-- if either of these is empty, "and" will yield empty, so that we
-- will end up with just Fent, which is what we want in that case.
-- Compute result by concatenating this first entry with the "and" of
-- the remaining parts of the left and right operands. Note that if
-- either of these is empty, "and" will yield empty, so that we will
-- end up with just Fent, which is what we want in that case.
return
FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
......@@ -6411,7 +6411,7 @@ package body Sem_Ch13 is
-- "or" --
----------
function "or" (Left, Right : RList) return RList is
function "or" (Left : RList; Right : RList) return RList is
FEnt : REnt;
-- First range of result
......@@ -6436,8 +6436,8 @@ package body Sem_Ch13 is
return Left;
end if;
-- Initialize result first entry from left or right operand
-- depending on which starts with the lower range.
-- Initialize result first entry from left or right operand depending
-- on which starts with the lower range.
if Left (SLeft).Lo < Right (SRight).Lo then
FEnt := Left (SLeft);
......@@ -6447,12 +6447,12 @@ package body Sem_Ch13 is
SRight := SRight + 1;
end if;
-- This loop eats ranges from left and right operands that
-- are contiguous with the first range we are gathering.
-- This loop eats ranges from left and right operands that are
-- contiguous with the first range we are gathering.
loop
-- Eat first entry in left operand if contiguous or
-- overlapped by gathered first operand of result.
-- Eat first entry in left operand if contiguous or overlapped by
-- gathered first operand of result.
if SLeft <= Left'Last
and then Left (SLeft).Lo <= FEnt.Hi + 1
......@@ -6460,8 +6460,8 @@ package body Sem_Ch13 is
FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
SLeft := SLeft + 1;
-- Eat first entry in right operand if contiguous or
-- overlapped by gathered right operand of result.
-- Eat first entry in right operand if contiguous or overlapped by
-- gathered right operand of result.
elsif SRight <= Right'Last
and then Right (SRight).Lo <= FEnt.Hi + 1
......@@ -6469,7 +6469,7 @@ package body Sem_Ch13 is
FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
SRight := SRight + 1;
-- All done if no more entries to eat!
-- All done if no more entries to eat
else
exit;
......@@ -6488,20 +6488,18 @@ package body Sem_Ch13 is
-- Build_Range --
-----------------
function Build_Range (Lo, Hi : Uint) return Node_Id is
function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
Result : Node_Id;
begin
if Lo = Hi then
return Build_Val (Hi);
else
Result :=
Make_Range (Loc,
Low_Bound => Build_Val (Lo),
High_Bound => Build_Val (Hi));
Set_Etype (Result, Btyp);
Set_Analyzed (Result);
return Result;
end if;
Result :=
Make_Range (Loc,
Low_Bound => Build_Val (Lo),
High_Bound => Build_Val (Hi));
Set_Etype (Result, Btyp);
Set_Analyzed (Result);
return Result;
end Build_Range;
---------------
......@@ -6911,11 +6909,7 @@ package body Sem_Ch13 is
-- Convert range into required form
if Lo = Hi then
Append_To (Plist, Build_Val (Lo));
else
Append_To (Plist, Build_Range (Lo, Hi));
end if;
Append_To (Plist, Build_Range (Lo, Hi));
end if;
end;
end loop;
......@@ -9452,12 +9446,12 @@ package body Sem_Ch13 is
-- storage orders differ.
if (Is_Record_Type (T1) or else Is_Array_Type (T1))
and then
and then
(Is_Record_Type (T2) or else Is_Array_Type (T2))
and then
(Component_Alignment (T1) /= Component_Alignment (T2)
or else
Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2))
then
return False;
end if;
......
gcc/ada/sem_ch4.adb
......@@ -1248,14 +1248,8 @@ package body Sem_Ch4 is
-----------------------------
procedure Analyze_Case_Expression (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
FirstX : constant Node_Id := Expression (First (Alternatives (N)));
Alt : Node_Id;
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Dont_Care : Boolean;
Others_Present : Boolean;
function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean;
-- Determine whether subtype Subtyp has aspect Static_Predicate
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
......@@ -1270,6 +1264,28 @@ package body Sem_Ch4 is
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
--------------------------
-- Has_Static_Predicate --
--------------------------
function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is
Item : Node_Id;
begin
Item := First_Rep_Item (Subtyp);
while Present (Item) loop
if Nkind (Item) = N_Aspect_Specification
and then Chars (Identifier (Item)) = Name_Static_Predicate
then
return True;
end if;
Next_Rep_Item (Item);
end loop;
return False;
end Has_Static_Predicate;
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
......@@ -1280,6 +1296,17 @@ package body Sem_Ch4 is
("choice given in case expression is not static!", Choice);
end Non_Static_Choice_Error;
-- Local variables
Expr : constant Node_Id := Expression (N);
FirstX : constant Node_Id := Expression (First (Alternatives (N)));
Alt : Node_Id;
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Dont_Care : Boolean;
Others_Present : Boolean;
-- Start of processing for Analyze_Case_Expression
begin
......@@ -1364,9 +1391,22 @@ package body Sem_Ch4 is
Exp_Type := Exp_Btype;
end if;
-- The case expression alternatives cover the range of a static subtype
-- subject to aspect Static_Predicate. Do not check the choices when the
-- case expression has not been fully analyzed yet because this may lead
-- to bogus errors.
if Is_Static_Subtype (Exp_Type)
and then Has_Static_Predicate (Exp_Type)
and then In_Spec_Expression
then
null;
-- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
else
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
end if;
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N
......@@ -1896,10 +1936,9 @@ package body Sem_Ch4 is
begin
A := First (Actions (N));
loop
while Present (A) loop
Analyze (A);
Next (A);
exit when No (A);
end loop;
-- This test needs a comment ???
......
gcc/ada/set_targ.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E T _ T A R G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2013, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Debug; use Debug;
with Get_Targ; use Get_Targ;
with Opt; use Opt;
with Output; use Output;
with System; use System;
with System.OS_Lib; use System.OS_Lib;
with Unchecked_Conversion;
package body Set_Targ is
---------------------------------------------
-- Data Used to Read/Write target.atp File --
---------------------------------------------
File_Name : aliased constant String := "target.atp";
-- Name of file to read/write
-- Table of string names written to file
subtype Str is String;
S_Bits_BE : constant Str := "Bits_BE";
S_Bits_Per_Unit : constant Str := "Bits_Per_Unit";
S_Bits_Per_Word : constant Str := "Bits_Per_Word";
S_Bytes_BE : constant Str := "Bytes_BE";
S_Char_Size : constant Str := "Char_Size";
S_Double_Float_Alignment : constant Str := "Double_Float_Alignment";
S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment";
S_Double_Size : constant Str := "Double_Size";
S_Float_Size : constant Str := "Float_Size";
S_Float_Words_BE : constant Str := "Float_Words_BE";
S_Int_Size : constant Str := "Int_Size";
S_Long_Double_Size : constant Str := "Long_Double_Size";
S_Long_Long_Size : constant Str := "Long_Long_Size";
S_Long_Size : constant Str := "Long_Size";
S_Maximum_Alignment : constant Str := "Maximum_Alignment";
S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field";
S_Pointer_Size : constant Str := "Pointer_Size";
S_Short_Size : constant Str := "Short_Size";
S_Strict_Alignment : constant Str := "Strict_Alignment";
S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment";
S_Wchar_T_Size : constant Str := "Wchar_T_Size";
S_Words_BE : constant Str := "Words_BE";
-- Table of names
type AStr is access all String;
DTN : constant array (Nat range <>) of AStr := (
S_Bits_BE 'Unrestricted_Access,
S_Bits_Per_Unit 'Unrestricted_Access,
S_Bits_Per_Word 'Unrestricted_Access,
S_Bytes_BE 'Unrestricted_Access,
S_Char_Size 'Unrestricted_Access,
S_Double_Float_Alignment 'Unrestricted_Access,
S_Double_Scalar_Alignment 'Unrestricted_Access,
S_Double_Size 'Unrestricted_Access,
S_Float_Size 'Unrestricted_Access,
S_Float_Words_BE 'Unrestricted_Access,
S_Int_Size 'Unrestricted_Access,
S_Long_Double_Size 'Unrestricted_Access,
S_Long_Long_Size 'Unrestricted_Access,
S_Long_Size 'Unrestricted_Access,
S_Maximum_Alignment 'Unrestricted_Access,
S_Max_Unaligned_Field 'Unrestricted_Access,
S_Pointer_Size 'Unrestricted_Access,
S_Short_Size 'Unrestricted_Access,
S_Strict_Alignment 'Unrestricted_Access,
S_System_Allocator_Alignment 'Unrestricted_Access,
S_Wchar_T_Size 'Unrestricted_Access,
S_Words_BE 'Unrestricted_Access);
-- Table of corresponding value pointers
DTV : constant array (Nat range <>) of System.Address := (
Bits_BE 'Address,
Bits_Per_Unit 'Address,
Bits_Per_Word 'Address,
Bytes_BE 'Address,
Char_Size 'Address,
Double_Float_Alignment 'Address,
Double_Scalar_Alignment 'Address,
Double_Size 'Address,
Float_Size 'Address,
Float_Words_BE 'Address,
Int_Size 'Address,
Long_Double_Size 'Address,
Long_Long_Size 'Address,
Long_Size 'Address,
Maximum_Alignment 'Address,
Max_Unaligned_Field 'Address,
Pointer_Size 'Address,
Short_Size 'Address,
Strict_Alignment 'Address,
System_Allocator_Alignment 'Address,
Wchar_T_Size 'Address,
Words_BE 'Address);
DTR : array (Nat range DTV'Range) of Boolean := (others => False);
-- Table of flags used to validate that all values are present in file
-----------------------
-- Local Subprograms --
-----------------------
procedure Fail (E : String);
pragma No_Return (Fail);
-- Terminate program with fatal error message passed as parameter
type C_String is array (0 .. 255) of aliased Character;
pragma Convention (C, C_String);
-- String long enough to hold any mode name for the following call
procedure Register_Float_Type
(Name : C_String;
Digs : Natural;
Complex : Boolean;
Count : Natural;
Float_Rep : Float_Rep_Kind;
Size : Positive;
Alignment : Natural);
pragma Convention (C, Register_Float_Type);
-- Call back to allow the back end to register available types. This call
-- back makes entries in the FPT_Mode_Table for any floating point types
-- reported by the back end. Name is the name of the type as a normal
-- format Null-terminated string. Digs is the number of digits, where 0
-- means it is not a fpt type (ignored during registration). Complex is
-- non-zero if the type has real and imaginary parts (also ignored during
-- registration). Count is the number of elements in a vector type (zero =
-- not a vector, registration ignores vectors). Float_Rep shows the kind of
-- floating-point type, and Size/Alignment are the size/alignment in bits.
--
-- So to summarize, the only types that are actually registered have Digs
-- non-zero, Complex zero (false), and Count zero (not a vector).
----------
-- Fail --
----------
procedure Fail (E : String) is
E_Fatal : constant := 4;
-- Code for fatal error
begin
Write_Str (E);
Write_Eol;
OS_Exit (E_Fatal);
end Fail;
-------------------------
-- Register_Float_Type --
-------------------------
procedure Register_Float_Type
(Name : C_String;
Digs : Natural;
Complex : Boolean;
Count : Natural;
Float_Rep : Float_Rep_Kind;
Size : Positive;
Alignment : Natural)
is
T : String (1 .. Name'Length);
Last : Natural := 0;
procedure Dump;
-- Dump information given by the back end for the type to register
----------
-- Dump --
----------
procedure Dump is
begin
Write_Str ("type " & T (1 .. Last) & " is ");
if Count > 0 then
Write_Str ("array (1 .. ");
Write_Int (Int (Count));
if Complex then
Write_Str (", 1 .. 2");
end if;
Write_Str (") of ");
elsif Complex then
Write_Str ("array (1 .. 2) of ");
end if;
if Digs > 0 then
Write_Str ("digits ");
Write_Int (Int (Digs));
Write_Line (";");
Write_Str ("pragma Float_Representation (");
case Float_Rep is
when IEEE_Binary =>
Write_Str ("IEEE");
when VAX_Native =>
case Digs is
when 6 =>
Write_Str ("VAXF");
when 9 =>
Write_Str ("VAXD");
when 15 =>
Write_Str ("VAXG");
when others =>
Write_Str ("VAX_");
Write_Int (Int (Digs));
end case;
when AAMP => Write_Str ("AAMP");
end case;
Write_Line (", " & T (1 .. Last) & ");");
else
Write_Str ("mod 2**");
Write_Int (Int (Size / Positive'Max (1, Count)));
Write_Line (";");
end if;
Write_Str ("for " & T (1 .. Last) & "'Size use ");
Write_Int (Int (Size));
Write_Line (";");
Write_Str ("for " & T (1 .. Last) & "'Alignment use ");
Write_Int (Int (Alignment / 8));
Write_Line (";");
Write_Eol;
end Dump;
-- Start of processing for Register_Float_Type
begin
-- Acquire name
for J in T'Range loop
T (J) := Name (Name'First + J - 1);
if T (J) = ASCII.NUL then
Last := J - 1;
exit;
end if;
end loop;
-- Dump info if debug flag set
if Debug_Flag_Dot_B then
Dump;
end if;
-- Acquire entry if non-vector non-complex fpt type (digits non-zero)
if Digs > 0 and then not Complex and then Count = 0 then
Num_FPT_Modes := Num_FPT_Modes + 1;
FPT_Mode_Table (Num_FPT_Modes) :=
(NAME => new String'(T (1 .. Last)),
DIGS => Digs,
FLOAT_REP => Float_Rep,
SIZE => Size,
ALIGNMENT => Alignment);
end if;
end Register_Float_Type;
-----------------------------------
-- Write_Target_Dependent_Values --
-----------------------------------
-- We do this at the System.Os_Lib level, since we have to do the read at
-- that level anyway, so it is easier and more consistent to follow the
-- same path for the write.
procedure Write_Target_Dependent_Values is
Fdesc : File_Descriptor;
OK : Boolean;
Buffer : String (1 .. 80);
Buflen : Natural;
-- Buffer used to build line one of file
type ANat is access all Natural;
-- Pointer to Nat or Pos value (it is harmless to treat Pos values and
-- Nat values as Natural via Unchecked_Conversion).
function To_ANat is new Unchecked_Conversion (Address, ANat);
procedure AddC (C : Character);
-- Add one character to buffer
procedure AddN (N : Natural);
-- Add representation of integer N to Buffer, updating Buflen. N
-- must be less than 1000, and output is 3 characters with leading
-- spaces as needed.
procedure Write_Line;
-- Output contents of Buffer (1 .. Buflen) followed by a New_Line,
-- and set Buflen back to zero.
----------
-- AddC --
----------
procedure AddC (C : Character) is
begin
Buflen := Buflen + 1;
Buffer (Buflen) := C;
end AddC;
----------
-- AddN --
----------
procedure AddN (N : Natural) is
begin
if N > 999 then
raise Program_Error;
end if;
if N > 99 then
AddC (Character'Val (48 + N / 100));
else
AddC (' ');
end if;
if N > 9 then
AddC (Character'Val (48 + N / 10 mod 10));
else
AddC (' ');
end if;
AddC (Character'Val (48 + N mod 10));
end AddN;
----------------
-- Write_Line --
----------------
procedure Write_Line is
begin
AddC (ASCII.LF);
if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then
Delete_File (File_Name'Address, OK);
Fail ("disk full writing target.atp");
end if;
Buflen := 0;
end Write_Line;
-- Start of processing for Write_Target_Dependent_Values
begin
Fdesc := Create_File (File_Name'Address, Text);
if Fdesc = Invalid_FD then
Fail ("cannot create target.atp");
end if;
-- Loop through values
for J in DTN'Range loop
-- Output name
Buflen := DTN (J)'Length;
Buffer (1 .. Buflen) := DTN (J).all;
-- Line up values
while Buflen < 26 loop
AddC (' ');
end loop;
AddC (' ');
AddC (' ');
-- Output value and write line
AddN (To_ANat (DTV (J)).all);
Write_Line;
end loop;
-- Blank line to separate sections
Write_Line;
-- Write lines for registered FPT types
for J in 1 .. Num_FPT_Modes loop
declare
E : FPT_Mode_Entry renames FPT_Mode_Table (J);
begin
Buflen := E.NAME'Last;
Buffer (1 .. Buflen) := E.NAME.all;
-- Pad out to line up values
while Buflen < 11 loop
AddC (' ');
end loop;
AddC (' ');
AddC (' ');
AddN (E.DIGS);
AddC (' ');
AddC (' ');
case E.FLOAT_REP is
when IEEE_Binary =>
AddC ('I');
when VAX_Native =>
AddC ('V');
when AAMP =>
AddC ('A');
end case;
AddC (' ');
AddN (E.SIZE);
AddC (' ');
AddN (E.ALIGNMENT);
Write_Line;
end;
end loop;
-- Close file
Close (Fdesc, OK);
if not OK then
Fail ("disk full writing target.atp");
end if;
end Write_Target_Dependent_Values;
-- Package Initialization, set target dependent values. This must be done
-- early on, before we start accessing various compiler packages, since
-- these values are used all over the place.
begin
-- First step: see if the -gnateT switch is present. As we have noted,
-- this has to be done very early, so can not depend on the normal circuit
-- for reading switches and setting switches in opt. The following code
-- will set Opt.Target_Dependent_Info_Read if an option starting -gnatet
-- is present in the options string.
declare
type Arg_Array is array (Nat) of Big_String_Ptr;
type Arg_Array_Ptr is access Arg_Array;
-- Types to access compiler arguments
save_argc : Nat;
pragma Import (C, save_argc);
-- Saved value of argc (number of arguments), imported from misc.c
save_argv : Arg_Array_Ptr;
pragma Import (C, save_argv);
-- Saved value of argv (argument pointers), imported from misc.c
begin
-- Loop through arguments looking for -gnateT, also look for -gnatd.b
for Arg in 1 .. save_argc - 1 loop
declare
Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
begin
if Argv_Ptr (1 .. 7) = "-gnateT" then
Opt.Target_Dependent_Info_Read := True;
elsif Argv_Ptr (1 .. 8) = "-gnatd.b" then
Debug_Flag_Dot_B := True;
end if;
end;
end loop;
end;
-- If the switch is not set, we get all values from the back end
if not Opt.Target_Dependent_Info_Read then
-- Set values set by direct calls to the back end
Bits_BE := Get_Bits_BE;
Bits_Per_Unit := Get_Bits_Per_Unit;
Bits_Per_Word := Get_Bits_Per_Word;
Bytes_BE := Get_Bytes_BE;
Char_Size := Get_Char_Size;
Double_Float_Alignment := Get_Double_Float_Alignment;
Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
Double_Size := Get_Double_Size;
Float_Size := Get_Float_Size;
Float_Words_BE := Get_Float_Words_BE;
Int_Size := Get_Int_Size;
Long_Double_Size := Get_Long_Double_Size;
Long_Long_Size := Get_Long_Long_Size;
Long_Size := Get_Long_Size;
Maximum_Alignment := Get_Maximum_Alignment;
Max_Unaligned_Field := Get_Max_Unaligned_Field;
Pointer_Size := Get_Pointer_Size;
Short_Size := Get_Short_Size;
Strict_Alignment := Get_Strict_Alignment;
System_Allocator_Alignment := Get_System_Allocator_Alignment;
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
-- Register floating-point types from the back end (depending on the
-- back end in use, we have to do different things to get this info).
case Get_Back_End is
-- GCC back end, get information using Enumerate_Modes
when GCC =>
declare
type Register_Type_Proc is access procedure
(C_Name : C_String;
Digs : Natural;
Complex : Boolean;
Count : Natural;
Float_Rep : Float_Rep_Kind;
Size : Positive;
Alignment : Natural);
pragma Convention (C, Register_Type_Proc);
-- Call back procedure for Register_Back_End_Types
procedure Enumerate_Modes (Call_Back : Register_Type_Proc);
pragma Import (C, Enumerate_Modes, "enumerate_modes");
-- Back end procedure that does the call backs (see misc.c)
begin
Num_FPT_Modes := 0;
Enumerate_Modes (Register_Float_Type'Access);
end;
-- AAMP back end, supply the two needed types directly
when AAMP =>
declare
Str : C_String;
begin
Str (1 .. 6) := "float" & ASCII.NUL;
Register_Float_Type
(Name => Str,
Digs => 6,
Complex => False,
Count => 0,
Float_Rep => AAMP,
Size => 32,
Alignment => 16);
Str (1 .. 7) := "double" & ASCII.NUL;
Register_Float_Type
(Name => Str,
Digs => 9,
Complex => False,
Count => 0,
Float_Rep => AAMP,
Size => 48,
Alignment => 16);
end;
-- DotNet TBD
when DOTNET =>
null;
end case;
-- Case of reading the target dependent values from target.atp
-- This is bit more complex than might be expected, because it has to
-- be done very early. All kinds of packages depend on these values,
-- and we can't wait till the normal processing of reading command line
-- switches etc to read the file. We do this at the System.OS_Lib level
-- since it is too early to be using Osint directly.
else
Read_File : declare
File_Desc : File_Descriptor;
N : Natural;
type ANat is access all Natural;
-- Pointer to Nat or Pos value (it is harmless to treat Pos values
-- as Nat via Unchecked_Conversion).
function To_ANat is new Unchecked_Conversion (Address, ANat);
VP : ANat;
Buffer : String (1 .. 2000);
Buflen : Natural;
-- File information and length (2000 easily enough!)
Nam_Buf : String (1 .. 40);
Nam_Len : Natural;
procedure Check_Spaces;
-- Checks that we have one or more spaces and skips them
procedure FailN (S : String);
-- Calls Fail prefixing "target.atp: " to the start of the given
-- string, and " name" to the end where name is the currently
-- gathered name in Nam_Buf, surrounded by quotes.
procedure Get_Name;
-- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
-- Skip_Spaces to skip any following spaces. Note that the name is
-- terminated by a sequence of at least two spaces.
function Get_Nat return Natural;
-- N on entry points to decimal integer, scan out decimal integer
-- and return it, leaving N pointing to following space or LF.
procedure Skip_Spaces;
-- Skip past spaces
------------------
-- Check_Spaces --
------------------
procedure Check_Spaces is
begin
if N > Buflen or else Buffer (N) /= ' ' then
FailN ("missing space for");
end if;
Skip_Spaces;
return;
end Check_Spaces;
-----------
-- FailN --
-----------
procedure FailN (S : String) is
begin
Fail ("target.atp: " & S & " """ & Nam_Buf (1 .. Nam_Len) & '"');
end FailN;
--------------
-- Get_Name --
--------------
procedure Get_Name is
begin
Nam_Len := 0;
-- Scan out name and put it in Nam_Buf
loop
if N > Buflen or else Buffer (N) = ASCII.LF then
FailN ("incorrectly formatted line for");
end if;
-- Name is terminated by two blanks
exit when N < Buflen and then Buffer (N .. N + 1) = " ";
Nam_Len := Nam_Len + 1;
if Nam_Len > Nam_Buf'Last then
Fail ("name too long");
end if;
Nam_Buf (Nam_Len) := Buffer (N);
N := N + 1;
end loop;
Check_Spaces;
end Get_Name;
-------------
-- Get_Nat --
-------------
function Get_Nat return Natural is
Result : Natural := 0;
begin
loop
if N > Buflen
or else Buffer (N) not in '0' .. '9'
or else Result > 999
then
FailN ("bad value for");
end if;
Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
N := N + 1;
exit when N <= Buflen
and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
end loop;
return Result;
end Get_Nat;
-----------------
-- Skip_Spaces --
-----------------
procedure Skip_Spaces is
begin
while N <= Buflen and Buffer (N) = ' ' loop
N := N + 1;
end loop;
end Skip_Spaces;
-- Start of processing for Read_File
begin
File_Desc := Open_Read ("target.atp", Text);
if File_Desc = Invalid_FD then
Fail ("cannot read target.atp file");
end if;
Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
if Buflen = Buffer'Length then
Fail ("target.atp file is too long");
end if;
-- Scan through file for properly formatted entries in first section
N := 1;
while N <= Buflen and then Buffer (N) /= ASCII.LF loop
Get_Name;
-- Validate name and get corresponding value pointer
VP := null;
for J in DTN'Range loop
if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
VP := To_ANat (DTV (J));
DTR (J) := True;
exit;
end if;
end loop;
if VP = null then
FailN ("unrecognized name");
end if;
-- Scan out value
VP.all := Get_Nat;
if N > Buflen or else Buffer (N) /= ASCII.LF then
FailN ("misformatted line for");
end if;
N := N + 1; -- skip LF
end loop;
-- Fall through this loop when all lines in first section read.
-- Check that values have been supplied for all entries.
for J in DTR'Range loop
if not DTR (J) then
Fail ("missing entry in target.atp for " & DTN (J).all);
end if;
end loop;
-- Now acquire FPT entries
if N >= Buflen then
Fail ("target.atp is missing entries for FPT modes");
end if;
if Buffer (N) = ASCII.LF then
N := N + 1;
else
Fail ("target.atp is missing blank line");
end if;
Num_FPT_Modes := 0;
while N <= Buflen loop
Get_Name;
Num_FPT_Modes := Num_FPT_Modes + 1;
declare
E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
begin
E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
E.DIGS := Get_Nat;
Check_Spaces;
case Buffer (N) is
when 'I' =>
E.FLOAT_REP := IEEE_Binary;
when 'V' =>
E.FLOAT_REP := VAX_Native;
when 'A' =>
E.FLOAT_REP := AAMP;
when others =>
FailN ("bad float rep field for");
end case;
N := N + 1;
Check_Spaces;
E.SIZE := Get_Nat;
Check_Spaces;
E.ALIGNMENT := Get_Nat;
if Buffer (N) /= ASCII.LF then
FailN ("junk at end of line for");
end if;
N := N + 1;
end;
end loop;
end Read_File;
end if;
end Set_Targ;
gcc/ada/set_targ.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E T _ T A R G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2013, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package handles setting target dependent parameters. If the -gnatet
-- switch is not set, then these values are taken from the back end (via the
-- routines in Get_Targ, and the enumerate_modes routine in misc.c). If the
-- switch is set, then the values are read from the target.atp file in the
-- current directory (usually written with the Write_Target_Dependent_Values
-- procedure defined in this package).
-- Note that all these values return sizes of C types with corresponding
-- names. This allows GNAT to define the corresponding Ada types to have
-- the same representation. There is one exception: the representation
-- of Wide_Character_Type uses twice the size of a C char, instead of the
-- size of wchar_t, since this corresponds to expected Ada usage.
with Einfo; use Einfo;
with Types; use Types;
package Set_Targ is
-----------------------------
-- Target-Dependent Values --
-----------------------------
-- The following is a table of target dependent values. In normal operation
-- these values are set by calling the appropriate C backend routines that
-- interface to back end routines that determine target characteristics.
-- If the -gnateT switch is used, then any values that are read from the
-- file target.atp in the current directory overwrite values set from the
-- back end. This is used by tools other than the compiler, e.g. to do
-- semantic analysis of programs that will run on some other target than
-- the machine on which the tool is run.
-- Note: fields marked with a question mark are boolean fields, where a
-- value of 0 is False, and a value of 1 is True.
Bits_BE : Nat; -- Bits stored big-endian?
Bits_Per_Unit : Pos; -- Bits in a storage unit
Bits_Per_Word : Pos; -- Bits in a word
Bytes_BE : Nat; -- Bytes stored big-endian?
Char_Size : Pos; -- Standard.Character'Size
Double_Float_Alignment : Nat; -- Alignment of double float
Double_Scalar_Alignment : Nat; -- Alignment of double length scalar
Double_Size : Pos; -- Standard.Long_Float'Size
Float_Size : Pos; -- Standard.Float'Size
Float_Words_BE : Nat; -- Float words stored big-endian?
Int_Size : Pos; -- Standard.Integer'Size
Long_Double_Size : Pos; -- Standard.Long_Long_Float'Size
Long_Long_Size : Pos; -- Standard.Long_Long_Integer'Size
Long_Size : Pos; -- Standard.Long_Integer'Size
Maximum_Alignment : Pos; -- Maximum permitted alignment
Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field
Pointer_Size : Pos; -- System.Address'Size
Short_Size : Pos; -- Standard.Short_Integer'Size
Strict_Alignment : Nat; -- Strict alignment?
System_Allocator_Alignment : Nat; -- Alignment for malloc calls
Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size
Words_BE : Nat; -- Words stored big-endian?
-------------------------------------
-- Registered Floating-Point Types --
-------------------------------------
-- This table contains the list of modes supported by the back-end as
-- provided by the back end routine enumerate_modes in misc.c. Note that
-- we only store floating-point modes (see Register_Float_Type).
type FPT_Mode_Entry is record
NAME : String_Ptr; -- Name of mode (no null character at end)
DIGS : Natural; -- Digits for floating-point type
FLOAT_REP : Float_Rep_Kind; -- Float representation
SIZE : Natural; -- Size in bits
ALIGNMENT : Natural; -- Alignment in bits
end record;
FPT_Mode_Table : array (1 .. 1000) of FPT_Mode_Entry;
Num_FPT_Modes : Natural;
-- Table containing the supported modes and number of entries
-----------------
-- Subprograms --
-----------------
procedure Write_Target_Dependent_Values;
-- This routine writes the file target.atp in the current directory with
-- the values of the global target parameters as listed above, and as set
-- by prior calls to Initialize/Read_Target_Dependent_Values. The format
-- of the target.atp file is as follows
--
-- First come the values of the variables defined in this spec:
--
-- One line per value
--
-- name value
--
-- where name is the name of the parameter, spelled out in full,
-- and cased as in the above list, and value is an unsigned decimal
-- integer. Two or more blanks separates the name from the value.
--
-- All the variables must be present, in alphabetical order (i.e. the
-- same order as the declarations in this spec).
--
-- Then there is a blank line to separate the two parts of the file. Then
-- come the lines showing the floating-point types to be registered.
--
-- One line per registered mode
--
-- name digs float_rep size alignment
--
-- where name is the string name of the type (which can have single
-- spaces embedded in the name (e.g. long double). The name is followed
-- by at least two blanks. The following fields are as described above
-- for a Mode_Entry (where float_rep is I/V/A for IEEE-754-Binary,
-- Vax_Native, AAMP), fields are separated by at least one blank, and
-- a LF character immediately follows the alignment field.
--
-- It is a fatal error to call this procedure if the target.atp file is
-- not found in the current directory.
end Set_Targ;
gcc/ada/xgnatugn.adb
......@@ -85,12 +85,6 @@
-- output. A line containing this escape sequence may not also contain
-- a ^alpha^beta^ sequence.
-- Process @ifset and @ifclear for the target flags (unw, vms);
-- this is because we have menu problems if we let makeinfo handle
-- these ifset/ifclear pairs.
-- Note: @ifset/@ifclear commands for the edition flags (FSFEDITION,
-- PROEDITION, GPLEDITION) are passed through unchanged
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
......
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