ortho debug/oread: disp float number in hexa.

2 files changed, 223 insertions, 63 deletions

diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb
index 8bdcce98e..a45bceca9 100644
--- a/src/ortho/debug/ortho_debug-disp.adb
+++ b/src/ortho/debug/ortho_debug-disp.adb
@@ -452,6 +452,81 @@ package body Ortho_Debug.Disp is
       end if;
    end Disp_Lit;
 
+   Xdigit : constant array (0 .. 15) of Character := "0123456789abcdef";
+
+   procedure Disp_Float_Lit
+     (Lit_Type : O_Tnode; Known : Boolean; Val : IEEE_Float_64)
+   is
+      pragma Assert (IEEE_Float_64'Machine_Radix = 2);
+      pragma Assert (IEEE_Float_64'Machine_Mantissa = 53);
+      Exp : Integer;
+      Man : Unsigned_64;
+      --  Res: sign(1) + 0x(2) + Man(53 / 3 ~= 18) + p(1) + sing(1) + exp(4)
+      Str : String (1 .. 1 + 2 + 18 + 1 + 1 + 4);
+      P : Natural;
+      Neg : Boolean;
+   begin
+      Exp := IEEE_Float_64'Exponent (Val) - 1;
+      Man := Unsigned_64 (abs (IEEE_Float_64'Fraction (Val)) * 2.0 ** 53);
+
+      --  Use decimal representation if there is no digit after the dot.
+      if Man = 0 then
+         Disp_Lit (Lit_Type, Known, "0.0");
+      else
+         pragma Assert (Shift_Right (Man, 52) = 1);
+
+         --  Remove hidden 1.
+         Man := Man and (2**52 - 1);
+
+         --  Remove trailing hex 0.
+         while Man /= 0 and (Man rem 16) = 0 loop
+            Man := Man / 16;
+         end loop;
+
+         --  Exponent.
+         P := Str'Last;
+         if Exp < 0 then
+            Neg := True;
+            Exp := -Exp;
+         else
+            Neg := False;
+         end if;
+         loop
+            Str (P) := Xdigit (Exp rem 10);
+            P := P - 1;
+            Exp := Exp / 10;
+            exit when Exp = 0;
+         end loop;
+         if Neg then
+            Str (P) := '-';
+            P := P - 1;
+         end if;
+         Str (P) := 'p';
+         P := P - 1;
+
+         --  Mantissa.
+         loop
+            Str (P) := Xdigit (Natural (Man and 15));
+            P := P - 1;
+            Man := Man / 16;
+            exit when Man = 0;
+         end loop;
+
+         P := P - 4;
+         Str (P + 1) := '0';
+         Str (P + 2) := 'x';
+         Str (P + 3) := '1';
+         Str (P + 4) := '.';
+
+         if Val < 0.0 then
+            Str (P) := '-';
+            P := P - 1;
+         end if;
+
+         Disp_Lit (Lit_Type, Known, Str (P + 1 .. Str'Last));
+      end if;
+   end Disp_Float_Lit;
+
    --  Display C. If CTYPE is set, this is the known type of C.
    procedure Disp_Cnode (C : O_Cnode; Ctype : O_Tnode)
    is
@@ -471,7 +546,7 @@ package body Ortho_Debug.Disp is
          when OC_Signed_Lit =>
             Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val));
          when OC_Float_Lit =>
-            Disp_Lit (C.Ctype, Known, IEEE_Float_64'Image (C.F_Val));
+            Disp_Float_Lit (C.Ctype, Known, C.F_Val);
          when OC_Boolean_Lit =>
             --  Always disp the type of boolean literals.
             Disp_Lit (C.Ctype, False, Get_String (C.B_Id));
diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb
index deaa5cf7d..42f72ea71 100644
--- a/src/ortho/oread/ortho_front.adb
+++ b/src/ortho/oread/ortho_front.adb
@@ -432,73 +432,64 @@ package body Ortho_Front is
    --  Previous token.
    Tok_Previous : Token_Type;
 
-   function Scan_Number (First_Char : Character) return Token_Type
-   is
-      function To_Digit (C : Character) return Integer is
-      begin
-         case C is
-            when '0' .. '9' =>
-               return Character'Pos (C) - Character'Pos ('0');
-            when 'A' .. 'F' =>
-               return Character'Pos (C) - Character'Pos ('A') + 10;
-            when 'a' .. 'f' =>
-               return Character'Pos (C) - Character'Pos ('a') + 10;
-            when others =>
-               return -1;
-         end case;
-      end To_Digit;
+   function To_Digit (C : Character) return Integer is
+   begin
+      case C is
+         when '0' .. '9' =>
+            return Character'Pos (C) - Character'Pos ('0');
+         when 'A' .. 'F' =>
+            return Character'Pos (C) - Character'Pos ('A') + 10;
+         when 'a' .. 'f' =>
+            return Character'Pos (C) - Character'Pos ('a') + 10;
+         when others =>
+            return -1;
+      end case;
+   end To_Digit;
 
-      function Is_Digit (C : Character) return Boolean is
-      begin
-         case C is
-            when '0' .. '9'
-              | 'A' .. 'F'
-              | 'a' .. 'f' =>
-               return True;
-            when others =>
-               return False;
-         end case;
-      end Is_Digit;
+   function Is_Digit (C : Character) return Boolean is
+   begin
+      case C is
+         when '0' .. '9'
+           | 'A' .. 'F'
+           | 'a' .. 'f' =>
+            return True;
+         when others =>
+            return False;
+      end case;
+   end Is_Digit;
 
-      After_Point : Integer;
+   function Scan_Hex_Number return Token_Type
+   is
       C : Character;
       Exp : Integer;
       Exp_Neg : Boolean;
-      Base : Unsigned_64;
+      After_Point : Natural;
    begin
       Token_Number := 0;
-      C := First_Char;
+      C := Get_Char;
+      if not Is_Digit (C) then
+         Scan_Error ("digit expected after '0x'");
+      end if;
       loop
-         Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C));
+         Token_Number := Token_Number * 16 + Unsigned_64 (To_Digit (C));
          C := Get_Char;
          exit when not Is_Digit (C);
       end loop;
-      if C = '#' then
-         Base := Token_Number;
-         Token_Number := 0;
-         C := Get_Char;
-         loop
-            if C /= '_' then
-               Token_Number :=
-                 Token_Number * Base + Unsigned_64 (To_Digit (C));
-            end if;
-            C := Get_Char;
-            exit when C = '#';
-         end loop;
-         return Tok_Num;
-      end if;
+
+      After_Point := 0;
       if C = '.' then
-         -- A real number.
-         After_Point := 0;
-         Token_Float := IEEE_Float_64 (Token_Number);
          loop
             C := Get_Char;
-            exit when C not in '0' .. '9';
-            Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C));
-            After_Point := After_Point + 1;
+            exit when not Is_Digit (C);
+            if Shift_Right (Token_Number, 60) = 0 then
+               Token_Number := Token_Number * 16 + Unsigned_64 (To_Digit (C));
+               After_Point := After_Point + 4;
+            end if;
          end loop;
-         if C = 'e' or C = 'E' then
-            Exp := 0;
+
+         Exp := 0;
+         if C = 'p' or C = 'P' then
+            -- A real number.
             C := Get_Char;
             Exp_Neg := False;
             if C = '-' then
@@ -506,30 +497,124 @@ package body Ortho_Front is
                C := Get_Char;
             elsif C = '+' then
                C := Get_Char;
-            elsif not Is_Digit (C) then
-               Scan_Error ("digit expected");
             end if;
-            while Is_Digit (C) loop
+            if not Is_Digit (C) then
+               Scan_Error ("digit expected after 'p'");
+            end if;
+            loop
                Exp := Exp * 10 + To_Digit (C);
                C := Get_Char;
+               exit when not Is_Digit (C);
             end loop;
             if Exp_Neg then
                Exp := -Exp;
             end if;
-            Exp := Exp - After_Point;
-         else
-            Exp := - After_Point;
          end if;
+         Exp := Exp - After_Point;
          Unget_Char;
-         Token_Float := Token_Float * 10.0 ** Exp;
-         if Token_Float > IEEE_Float_64'Last then
-            Token_Float := IEEE_Float_64'Last;
-         end if;
+         Token_Float :=
+           IEEE_Float_64'Scaling (IEEE_Float_64 (Token_Number), Exp);
          return Tok_Float_Num;
       else
          Unget_Char;
          return Tok_Num;
       end if;
+   end Scan_Hex_Number;
+
+   function Scan_Fp_Number return Token_Type
+   is
+      After_Point : Integer;
+      C : Character;
+      Exp : Integer;
+      Exp_Neg : Boolean;
+   begin
+      -- A real number.
+      After_Point := 0;
+      Token_Float := IEEE_Float_64 (Token_Number);
+      loop
+         C := Get_Char;
+         exit when C not in '0' .. '9';
+         Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C));
+         After_Point := After_Point + 1;
+      end loop;
+      if C = 'e' or C = 'E' then
+         Exp := 0;
+         C := Get_Char;
+         Exp_Neg := False;
+         if C = '-' then
+            Exp_Neg := True;
+            C := Get_Char;
+         elsif C = '+' then
+            C := Get_Char;
+         elsif not Is_Digit (C) then
+            Scan_Error ("digit expected");
+         end if;
+         while Is_Digit (C) loop
+            Exp := Exp * 10 + To_Digit (C);
+            C := Get_Char;
+         end loop;
+         if Exp_Neg then
+            Exp := -Exp;
+         end if;
+         Exp := Exp - After_Point;
+      else
+         Exp := - After_Point;
+      end if;
+      Unget_Char;
+      Token_Float := Token_Float * 10.0 ** Exp;
+      if Token_Float > IEEE_Float_64'Last then
+         Token_Float := IEEE_Float_64'Last;
+      end if;
+      return Tok_Float_Num;
+   end Scan_Fp_Number;
+
+   function Scan_Number (First_Char : Character) return Token_Type
+   is
+      C : Character;
+      Base : Unsigned_64;
+   begin
+      C := First_Char;
+      Token_Number := 0;
+
+      --  Handle '0x' prefix.
+      if C = '0' then
+         --  '0' can be discarded.
+         C := Get_Char;
+         if C = 'x' or C = 'X' then
+            return Scan_Hex_Number;
+         elsif C = '.' then
+            return Scan_Fp_Number;
+         elsif not Is_Digit (C) then
+            Unget_Char;
+            return Tok_Num;
+         end if;
+      end if;
+
+      loop
+         Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C));
+         C := Get_Char;
+         exit when not Is_Digit (C);
+      end loop;
+      if C = '#' then
+         Base := Token_Number;
+         Token_Number := 0;
+         C := Get_Char;
+         loop
+            if C /= '_' then
+               Token_Number :=
+                 Token_Number * Base + Unsigned_64 (To_Digit (C));
+            end if;
+            C := Get_Char;
+            exit when C = '#';
+         end loop;
+         return Tok_Num;
+      end if;
+      if C = '.' then
+         return Scan_Fp_Number;
+      else
+         Unget_Char;
+         return Tok_Num;
+      end if;
    end Scan_Number;
 
    procedure Scan_Comment