From 15b682ca9298dda6bc78a98ae4bba04dab2a9d26 Mon Sep 17 00:00:00 2001 From: Geert Bosch Date: Tue, 2 Aug 2011 12:41:24 +0000 Subject: [PATCH] cstand.adb (Register_Float_Type): Print information about type to register, if the Debug_Flag_Dot_B is set. 2011-08-02 Geert Bosch * 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 --- gcc/ada/ChangeLog | 21 +++++++++++++ gcc/ada/cstand.adb | 72 +++++++++++++++++++++++++++++++++++++++--- gcc/ada/debug.adb | 5 ++- gcc/ada/rtsfind.ads | 2 ++ gcc/ada/sem_ch13.adb | 1 + gcc/ada/sem_ch3.adb | 53 ++++++++++++++++++++++--------- gcc/ada/sem_prag.adb | 74 ++++++++++++++++++++++++++++++++++++++++++-- 7 files changed, 205 insertions(+), 23 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5cd284e9414..500a0a278d5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2011-08-02 Geert Bosch + + * 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 * inline.adb (Add_Inlined_Body): Adjust check for library-level inlined diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index fe3bf4530bb..26b19afd525 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -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))); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bc0e8f73c01..27ce9b0d87b 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -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. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ca8bfb85428..1ab979fbd94 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 06ed3480729..60851e496b3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2a8d7c19af3..337ff456c00 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 51e7f5fbda2..3bb93684358 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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;