OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cstand.adb (Register_Float_Type): Print information about type to register, if the Debug_Flag_Dot_B is set. 

2011-08-02  Geert Bosch  <bosch@adacore.com>

	* cstand.adb (Register_Float_Type): Print information about type to
	register, if the Debug_Flag_Dot_B is set.
	* debug.adb (Debug_Flag_Dot_B): Document d.b debug option.
	* rtsfind.ads (RE_Max_Base_Digits): New run time entity.
	* sem_ch3.adb (Floating_Point_Type_Declaration): Allow declarations
	with a requested precision of more than Max_Digits digits and no more
	than Max_Base_Digits digits, if a range specification is present and the
	Predefined_Float_Types list has a suitable type to derive from.
	* sem_ch3.adb (Rep_Item_Too_Early): Avoid generating error in the
	case of type completion with pragma Import
	* sem_prag.adb
	(Process_Import_Predefined_Type): Processing to complete a type
	with pragma Import. Currently supports floating point types only.
	(Set_Convention_From_Pragma): Do nothing without underlying type.
	(Process_Convention): Guard against absence of underlying type,
	which may happen when importing incomplete types.
	(Process_Import_Or_Interface): Handle case of importing predefined
	types. Tweak error message.

From-SVN: r177138
This commit is contained in:
Geert Bosch 2011-08-02 12:41:24 +00:00 committed by Arnaud Charlet
parent f8726f2b03
commit 15b682ca92
7 changed files with 205 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/ada/ChangeLog
View File

@ -1,3 +1,24 @@
2011-08-02 Geert Bosch <bosch@adacore.com>
* cstand.adb (Register_Float_Type): Print information about type to
register, if the Debug_Flag_Dot_B is set.
* debug.adb (Debug_Flag_Dot_B): Document d.b debug option.
* rtsfind.ads (RE_Max_Base_Digits): New run time entity.
* sem_ch3.adb (Floating_Point_Type_Declaration): Allow declarations
with a requested precision of more than Max_Digits digits and no more
than Max_Base_Digits digits, if a range specification is present and the
Predefined_Float_Types list has a suitable type to derive from.
* sem_ch3.adb (Rep_Item_Too_Early): Avoid generating error in the
case of type completion with pragma Import
* sem_prag.adb
(Process_Import_Predefined_Type): Processing to complete a type
with pragma Import. Currently supports floating point types only.
(Set_Convention_From_Pragma): Do nothing without underlying type.
(Process_Convention): Guard against absence of underlying type,
which may happen when importing incomplete types.
(Process_Import_Or_Interface): Handle case of importing predefined
types. Tweak error message.
2011-08-02 Eric Botcazou <ebotcazou@adacore.com>
* inline.adb (Add_Inlined_Body): Adjust check for library-level inlined

72
gcc/ada/cstand.adb
View File

@ -467,7 +467,7 @@ package body CStand is
N : Node_Id := First (Back_End_Float_Types);
begin
if Digits_Value (LLF) > Max_HW_Digs then
if Present (LLF) and then Digits_Value (LLF) > Max_HW_Digs then
LLF := Empty;
end if;
@ -2008,16 +2008,78 @@ package body CStand is
Size : Positive;
Alignment : Natural)
is
Last : Natural := Name'First - 1;
T : String (1 .. Name'Length);
Last : Natural := 0;
procedure Dump;
-- Dump information given by the back end for the type to register
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 & ");");
else
Write_Str ("mod 2**");
Write_Int (Int (Size / Positive'Max (1, Count)));
Write_Line (";");
end if;
Write_Str ("for " & T & "'Size use ");
Write_Int (Int (Size));
Write_Line (";");
Write_Str ("for " & T & "'Alignment use ");
Write_Int (Int (Alignment / 8));
Write_Line (";");
end Dump;
begin
for J in Name'Range loop
if Name (J) = ASCII.NUL then
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;
if Debug_Flag_Dot_B then
Dump;
end if;
if Digs > 0 and then not Complex and then Count = 0 then
declare
Ent : constant Entity_Id := New_Standard_Entity;
@ -2026,7 +2088,7 @@ package body CStand is
begin
Set_Defining_Identifier
(New_Node (N_Full_Type_Declaration, Stloc), Ent);
Make_Name (Ent, String (Name (Name'First .. Last)));
Make_Name (Ent, T (1 .. Last));
Set_Scope (Ent, Standard_Standard);
Build_Float_Type (Ent, Esize, Float_Rep, Pos (Digs));
Set_RM_Size (Ent, UI_From_Int (Int (Size)));

5
gcc/ada/debug.adb
View File

@ -92,7 +92,7 @@ package body Debug is
-- dZ Generate listing showing the contents of the dispatch tables
-- d.a Force Target_Strict_Alignment mode to True
-- d.b
-- d.b Dump backend types
-- d.c Generate inline concatenation, do not call procedure
-- d.d
-- d.e
@ -500,6 +500,9 @@ package body Debug is
-- would normally be false. Can be used for testing strict alignment
-- circuitry in the compiler.
-- d.b Dump back end types. During Create_Standard, the back end is
-- queried for all available types. This option shows them.
-- d.c Generate inline concatenation, instead of calling one of the
-- System.Concat_n.Str_Concat_n routines in cases where the latter
-- routines would normally be called.

2
gcc/ada/rtsfind.ads
View File

@ -650,6 +650,7 @@ package Rtsfind is
RE_Interrupt_Priority, -- System
RE_Lib_Stop, -- System
RE_Low_Order_First, -- System
RE_Max_Base_Digits, -- System
RE_Max_Priority, -- System
RE_Null_Address, -- System
RE_Priority, -- System
@ -1827,6 +1828,7 @@ package Rtsfind is
RE_Interrupt_Priority => System,
RE_Lib_Stop => System,
RE_Low_Order_First => System,
RE_Max_Base_Digits => System,
RE_Max_Priority => System,
RE_Null_Address => System,
RE_Priority => System,

1
gcc/ada/sem_ch13.adb
View File

@ -6958,6 +6958,7 @@ package body Sem_Ch13 is
if Is_Incomplete_Or_Private_Type (T)
and then No (Underlying_Type (T))
and then Get_Pragma_Id (N) /= Pragma_Import
then
Error_Msg_N
("representation item must be after full type declaration", N);

53
gcc/ada/sem_ch3.adb
View File

@ -15034,13 +15034,15 @@ package body Sem_Ch3 is
procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
Digs : constant Node_Id := Digits_Expression (Def);
Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float);
Digs_Val : Uint;
Base_Typ : Entity_Id;
Implicit_Base : Entity_Id;
Bound : Node_Id;
function Can_Derive_From (E : Entity_Id) return Boolean;
-- Find if given digits value allows derivation from specified type
-- Find if given digits value, and possibly a specified range, allows
-- derivation from specified type
---------------------
-- Can_Derive_From --
@ -15091,24 +15093,47 @@ package body Sem_Ch3 is
Process_Real_Range_Specification (Def);
if Can_Derive_From (Standard_Short_Float) then
Base_Typ := Standard_Short_Float;
elsif Can_Derive_From (Standard_Float) then
Base_Typ := Standard_Float;
elsif Can_Derive_From (Standard_Long_Float) then
Base_Typ := Standard_Long_Float;
elsif Can_Derive_From (Standard_Long_Long_Float) then
Base_Typ := Standard_Long_Long_Float;
-- Check that requested number of digits is not too high.
-- If we can't derive from any existing type, use long_long_float
if Digs_Val > Max_Digs_Val then
-- The check for Max_Base_Digits may be somewhat expensive, as it
-- requires reading System, so only do it when necessary.
declare
Max_Base_Digits : constant Uint :=
Expr_Value (Expression (Parent (RTE (RE_Max_Base_Digits))));
begin
if Digs_Val > Max_Base_Digits then
Error_Msg_Uint_1 := Max_Base_Digits;
Error_Msg_N ("digits value out of range, maximum is ^", Digs);
elsif No (Real_Range_Specification (Def)) then
Error_Msg_Uint_1 := Max_Digs_Val;
Error_Msg_N ("types with more than ^ digits need range spec "
& "('R'M 3.5.7(6))", Digs);
end if;
end;
end if;
Base_Typ := First (Predefined_Float_Types);
while Present (Base_Typ) and then not Can_Derive_From (Base_Typ) loop
Next (Base_Typ);
end loop;
-- If we can't derive from any existing type, use Long_Long_Float
-- and give appropriate message explaining the problem.
else
if No (Base_Typ) then
Base_Typ := Standard_Long_Long_Float;
if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
Error_Msg_N ("digits value out of range, maximum is ^", Digs);
if Digs_Val > Max_Digs_Val then
-- It might be the case that there is a type with the requested
-- range, just not the combination of digits and range.
Error_Msg_N
("no predefined type has requested range and precision",
Real_Range_Specification (Def));
else
Error_Msg_N

74
gcc/ada/sem_prag.adb
View File

@ -659,6 +659,11 @@ package body Sem_Prag is
procedure Process_Import_Or_Interface;
-- Common processing for Import of Interface
procedure Process_Import_Predefined_Type;
-- Processing for completing a type with pragma Import. This is used
-- to declare types that match predefined C types, especially for cases
-- without corresponding Ada predefined type.
procedure Process_Inline (Active : Boolean);
-- Common processing for Inline and Inline_Always. The parameter
-- indicates if the inline pragma is active, i.e. if it should actually
@ -2875,7 +2880,9 @@ package body Sem_Prag is
Set_Convention (E, C);
Set_Has_Convention_Pragma (E);
if Is_Incomplete_Or_Private_Type (E) then
if Is_Incomplete_Or_Private_Type (E)
and then Present (Underlying_Type (E))
then
Set_Convention (Underlying_Type (E), C);
Set_Has_Convention_Pragma (Underlying_Type (E), True);
end if;
@ -3033,7 +3040,8 @@ package body Sem_Prag is
or else Rep_Item_Too_Early (E, N)
then
raise Pragma_Exit;
else
elsif Present (Underlying_Type (E)) then
E := Underlying_Type (E);
end if;
@ -3850,6 +3858,58 @@ package body Sem_Prag is
end loop;
end Process_Generic_List;
------------------------------------
-- Process_Import_Predefined_Type --
------------------------------------
procedure Process_Import_Predefined_Type is
Loc : constant Source_Ptr := Sloc (N);
Ftyp : Node_Id := First (Predefined_Float_Types);
Decl : Node_Id;
Def : Node_Id;
Nam : Name_Id;
begin
String_To_Name_Buffer (Strval (Expression (Arg3)));
Nam := Name_Find;
while Present (Ftyp) and then Chars (Ftyp) /= Nam loop
Next (Ftyp);
end loop;
if Present (Ftyp) then
-- Don't build a derived type declaration, because predefined C
-- types have no declaration anywhere, so cannot really be named.
-- Instead build a full type declaration, starting with an
-- appropriate type definition is built
if Is_Floating_Point_Type (Ftyp) then
Def := Make_Floating_Point_Definition (Loc,
Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
Make_Real_Range_Specification (Loc,
Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
else
-- Should never have a predefined type we cannot handle
raise Program_Error;
end if;
-- Build and insert a Full_Type_Declaration, which will be
-- analyzed as soon as this list entry has been analyzed.
Decl := Make_Full_Type_Declaration (Loc,
Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
Type_Definition => Def);
Insert_After (N, Decl);
Mark_Rewrite_Insertion (Decl);
else
Error_Pragma_Arg ("no matching type found for pragma%",
Arg2);
end if;
end Process_Import_Predefined_Type;
---------------------------------
-- Process_Import_Or_Interface --
---------------------------------
@ -4118,9 +4178,17 @@ package body Sem_Prag is
end if;
end;
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
Check_No_Link_Name;
Check_Arg_Count (3);
Check_Arg_Is_Static_Expression (Arg3, Standard_String);
Process_Import_Predefined_Type;
else
Error_Pragma_Arg
("second argument of pragma% must be object or subprogram",
("second argument of pragma% must be object, subprogram" &
" or incomplete type",
Arg2);
end if;