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