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-2009 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       procedure Set_Digits (T : Unsigned) is
 103       begin
 104          if T >= BU then
 105             Set_Digits (T / BU);
 106             P := P + 1;
 107             S (P) := Hex (T mod BU);
 108          else
 109             P := P + 1;
 110             S (P) := Hex (T);
 111          end if;
 112       end Set_Digits;
 113
 114    --  Start of processing for Set_Image_Based_Unsigned
 115
 116    begin
 117
 118       if B >= 10 then
 119          P := P + 1;
 120          S (P) := '1';
 121       end if;
 122
 123       P := P + 1;
 124       S (P) := Character'Val (Character'Pos ('0') + B mod 10);
 125
 126       P := P + 1;
 127       S (P) := '#';
 128
 129       Set_Digits (V);
 130
 131       P := P + 1;
 132       S (P) := '#';
 133
 134       --  Add leading spaces if required by width parameter
 135
 136       if P - Start < W then
 137          F := P;
 138          P := Start + W;
 139          T := P;
 140
 141          while F > Start loop
 142             S (T) := S (F);
 143             T := T - 1;
 144             F := F - 1;
 145          end loop;
 146
 147          for J in Start + 1 .. T loop
 148             S (J) := ' ';
 149          end loop;
 150       end if;
 151
 152    end Set_Image_Based_Unsigned;
 153
 154 end System.Img_BIU;