cstand.adb (Register_Float_Type): Print information about type to register, if…

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

gcc/ada/ChangeLog

+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

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)));

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.

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,

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);

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

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;