gcc/ada/s-imgllb.adb

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