File : s-imgllw.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . I M G _ L L W --
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 -- --
19 -- --
20 -- --
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_LLW is
35
36 ---------------------------------------
37 -- Set_Image_Width_Long_Long_Integer --
38 ---------------------------------------
39
40 procedure Set_Image_Width_Long_Long_Integer
41 (V : Long_Long_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_Long_Long_Unsigned
53 (Long_Long_Unsigned (V), 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_Width_Long_Long_Unsigned
68 (Long_Long_Unsigned (-V), W - 1, S, P);
69 end;
70
71 -- Set minus sign in last leading blank location. Because of the
72 -- code above, there must be at least one such location.
73
74 while S (Start + 1) = ' ' loop
75 Start := Start + 1;
76 end loop;
77
78 S (Start) := '-';
79 end if;
80
81 end Set_Image_Width_Long_Long_Integer;
82
83 ----------------------------------------
84 -- Set_Image_Width_Long_Long_Unsigned --
85 ----------------------------------------
86
87 procedure Set_Image_Width_Long_Long_Unsigned
88 (V : Long_Long_Unsigned;
89 W : Integer;
90 S : out String;
91 P : in out Natural)
92 is
93 Start : constant Natural := P;
94 F, T : Natural;
95
96 procedure Set_Digits (T : Long_Long_Unsigned);
97 -- Set digits of absolute value of T
98
99 ----------------
100 -- Set_Digits --
101 ----------------
102
103 procedure Set_Digits (T : Long_Long_Unsigned) is
104 begin
105 if T >= 10 then
106 Set_Digits (T / 10);
107 P := P + 1;
108 S (P) := Character'Val (T mod 10 + Character'Pos ('0'));
109 else
110 P := P + 1;
111 S (P) := Character'Val (T + Character'Pos ('0'));
112 end if;
113 end Set_Digits;
114
115 -- Start of processing for Set_Image_Width_Long_Long_Unsigned
116
117 begin
118 Set_Digits (V);
119
120 -- Add leading spaces if required by width parameter
121
122 if P - Start < W then
123 F := P;
124 P := P + (W - (P - Start));
125 T := P;
126
127 while F > Start loop
128 S (T) := S (F);
129 T := T - 1;
130 F := F - 1;
131 end loop;
132
133 for J in Start + 1 .. T loop
134 S (J) := ' ';
135 end loop;
136 end if;
137
138 end Set_Image_Width_Long_Long_Unsigned;
139
140 end System.Img_LLW;