+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
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;
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;
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)));
-- 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
-- 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.
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
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,
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);
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 --
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 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;
- -- If we can't derive from any existing type, use long_long_float
+ 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
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
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;
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;
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 --
---------------------------------
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;
projects / gcc.git / commitdiff