gcc/ada/s-imgbiu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . I M G _ B I U                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2014, 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 with System.Unsigned_Types; use System.Unsigned_Types;
  33
  34 package body System.Img_BIU is
  35
  36    -----------------------------
  37    -- Set_Image_Based_Integer --
  38    -----------------------------
  39
  40    procedure Set_Image_Based_Integer
  41      (V : Integer;
  42       B : Natural;
  43       W : Integer;
  44       S : out String;
  45       P : in out Natural)
  46    is
  47       Start : Natural;
  48
  49    begin
  50       --  Positive case can just use the unsigned circuit directly
  51
  52       if V >= 0 then
  53          Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P);
  54
  55       --  Negative case has to set a minus sign. Note also that we have to be
  56       --  careful not to generate overflow with the largest negative number.
  57
  58       else
  59          P := P + 1;
  60          S (P) := ' ';
  61          Start := P;
  62
  63          declare
  64             pragma Suppress (Overflow_Check);
  65             pragma Suppress (Range_Check);
  66          begin
  67             Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P);
  68          end;
  69
  70          --  Set minus sign in last leading blank location. Because of the
  71          --  code above, there must be at least one such location.
  72
  73          while S (Start + 1) = ' ' loop
  74             Start := Start + 1;
  75          end loop;
  76
  77          S (Start) := '-';
  78       end if;
  79
  80    end Set_Image_Based_Integer;
  81
  82    ------------------------------
  83    -- Set_Image_Based_Unsigned --
  84    ------------------------------
  85
  86    procedure Set_Image_Based_Unsigned
  87      (V : Unsigned;
  88       B : Natural;
  89       W : Integer;
  90       S : out String;
  91       P : in out Natural)
  92    is
  93       Start : constant Natural := P;
  94       F, T  : Natural;
  95       BU    : constant Unsigned := Unsigned (B);
  96       Hex   : constant array
  97                 (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF";
  98
  99       procedure Set_Digits (T : Unsigned);
 100       --  Set digits of absolute value of T
 101
 102       ----------------
 103       -- Set_Digits --
 104       ----------------
 105
 106       procedure Set_Digits (T : Unsigned) is
 107       begin
 108          if T >= BU then
 109             Set_Digits (T / BU);
 110             P := P + 1;
 111             S (P) := Hex (T mod BU);
 112          else
 113             P := P + 1;
 114             S (P) := Hex (T);
 115          end if;
 116       end Set_Digits;
 117
 118    --  Start of processing for Set_Image_Based_Unsigned
 119
 120    begin
 121
 122       if B >= 10 then
 123          P := P + 1;
 124          S (P) := '1';
 125       end if;
 126
 127       P := P + 1;
 128       S (P) := Character'Val (Character'Pos ('0') + B mod 10);
 129
 130       P := P + 1;
 131       S (P) := '#';
 132
 133       Set_Digits (V);
 134
 135       P := P + 1;
 136       S (P) := '#';
 137
 138       --  Add leading spaces if required by width parameter
 139
 140       if P - Start < W then
 141          F := P;
 142          P := Start + W;
 143          T := P;
 144
 145          while F > Start loop
 146             S (T) := S (F);
 147             T := T - 1;
 148             F := F - 1;
 149          end loop;
 150
 151          for J in Start + 1 .. T loop
 152             S (J) := ' ';
 153          end loop;
 154       end if;
 155
 156    end Set_Image_Based_Unsigned;
 157
 158 end System.Img_BIU;