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