GCC v8.2
[gcc.git] / gcc / ada / libgnat / 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-2018, 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;