gcc/ada/libgnat/s-imageb.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . I M A G E _ B                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 package body System.Image_B is
  33
  34    -----------------------------
  35    -- Set_Image_Based_Integer --
  36    -----------------------------
  37
  38    procedure Set_Image_Based_Integer
  39      (V : Int;
  40       B : Natural;
  41       W : Integer;
  42       S : out String;
  43       P : in out Natural)
  44    is
  45       Start : Natural;
  46
  47    begin
  48       --  Positive case can just use the unsigned circuit directly
  49
  50       if V >= 0 then
  51          Set_Image_Based_Unsigned (Uns (V), B, W, S, P);
  52
  53       --  Negative case has to set a minus sign. Note also that we have to be
  54       --  careful not to generate overflow with the largest negative number.
  55
  56       else
  57          P := P + 1;
  58          S (P) := ' ';
  59          Start := P;
  60
  61          declare
  62             pragma Suppress (Overflow_Check);
  63             pragma Suppress (Range_Check);
  64          begin
  65             Set_Image_Based_Unsigned (Uns (-V), B, W - 1, S, P);
  66          end;
  67
  68          --  Set minus sign in last leading blank location. Because of the
  69          --  code above, there must be at least one such location.
  70
  71          while S (Start + 1) = ' ' loop
  72             Start := Start + 1;
  73          end loop;
  74
  75          S (Start) := '-';
  76       end if;
  77
  78    end Set_Image_Based_Integer;
  79
  80    ------------------------------
  81    -- Set_Image_Based_Unsigned --
  82    ------------------------------
  83
  84    procedure Set_Image_Based_Unsigned
  85      (V : Uns;
  86       B : Natural;
  87       W : Integer;
  88       S : out String;
  89       P : in out Natural)
  90    is
  91       Start : constant Natural := P + 1;
  92       BU    : constant Uns := Uns (B);
  93       Hex   : constant array
  94                 (Uns range 0 .. 15) of Character := "0123456789ABCDEF";
  95
  96       Nb_Digits : Natural := 1;
  97       T : Uns := V;
  98
  99    begin
 100
 101       --  First we compute the number of characters needed for representing
 102       --  the number.
 103       loop
 104          T := T / BU;
 105          exit when T = 0;
 106          Nb_Digits := Nb_Digits + 1;
 107       end loop;
 108
 109       P := Start;
 110
 111       --  Pad S with spaces up to W reduced by Nb_Digits plus extra 3-4
 112       --  characters needed for displaying the base.
 113       while P < Start + W - Nb_Digits - 3 - B / 10 loop
 114          S (P) := ' ';
 115          P := P + 1;
 116       end loop;
 117
 118       if B >= 10 then
 119          S (P) := '1';
 120          P := P + 1;
 121       end if;
 122
 123       S (P) := Hex (BU mod 10);
 124       P := P + 1;
 125
 126       S (P) := '#';
 127       P := P + 1;
 128
 129       --  We now populate digits from the end of the value to the beginning
 130       T := V;
 131       for J in reverse P .. P + Nb_Digits - 1 loop
 132          S (J) := Hex (T mod BU);
 133          T := T / BU;
 134       end loop;
 135
 136       P := P + Nb_Digits;
 137       S (P) := '#';
 138
 139    end Set_Image_Based_Unsigned;
 140
 141 end System.Image_B;