[1] Add d.b debug option for showing available back end types
This debug option prints out information on all types that the
back end indicates it supports.
[2] Allow fpt types with more than Long_Long_Float'Digits digits
This patch takes advantage of the new infrastructure in Cstand to allow
deriving from predefined floating point types that are not in Standard and
may have more than Max_Digits digits. This will allow definition of
Interfaces.C.long_double on systems where this type is not supported by
hardware.
[3] Add support for importing predefined C floating point types
This is needed to reliably define types such as "long double"
which may have no corresponding predefined type in Ada.
The following should compile without error:
procedure it is
type T;
pragma Import (C, T, "long double");
begin
null;
end it;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Geert Bosch <bo...@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.
Index: cstand.adb
===================================================================
--- cstand.adb (revision 177137)
+++ cstand.adb (working copy)
@@ -467,7 +467,7 @@
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 @@
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 @@
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)));
Index: debug.adb
===================================================================
--- debug.adb (revision 177040)
+++ debug.adb (working copy)
@@ -92,7 +92,7 @@
-- 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 @@
-- 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.
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 176998)
+++ rtsfind.ads (working copy)
@@ -650,6 +650,7 @@
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 @@
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,
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 177123)
+++ sem_ch13.adb (working copy)
@@ -6958,6 +6958,7 @@
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);
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 177135)
+++ sem_ch3.adb (working copy)
@@ -15034,13 +15034,15 @@
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,25 +15093,48 @@
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
("range too large for any predefined type",
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 177123)
+++ sem_prag.adb (working copy)
@@ -659,6 +659,11 @@
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 @@
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 @@
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 @@
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 @@
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;
