1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . T E X T _ I O . I N T E G E R _ A U X -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; 33 34with System.Img_BIU; use System.Img_BIU; 35with System.Img_Int; use System.Img_Int; 36with System.Img_LLB; use System.Img_LLB; 37with System.Img_LLI; use System.Img_LLI; 38with System.Img_LLW; use System.Img_LLW; 39with System.Img_WIU; use System.Img_WIU; 40with System.Val_Int; use System.Val_Int; 41with System.Val_LLI; use System.Val_LLI; 42 43package body Ada.Text_IO.Integer_Aux is 44 45 ----------------------- 46 -- Local Subprograms -- 47 ----------------------- 48 49 procedure Load_Integer 50 (File : File_Type; 51 Buf : out String; 52 Ptr : in out Natural); 53 -- This is an auxiliary routine that is used to load a possibly signed 54 -- integer literal value from the input file into Buf, starting at Ptr + 1. 55 -- On return, Ptr is set to the last character stored. 56 57 ------------- 58 -- Get_Int -- 59 ------------- 60 61 procedure Get_Int 62 (File : File_Type; 63 Item : out Integer; 64 Width : Field) 65 is 66 Buf : String (1 .. Field'Last); 67 Ptr : aliased Integer := 1; 68 Stop : Integer := 0; 69 70 begin 71 if Width /= 0 then 72 Load_Width (File, Width, Buf, Stop); 73 String_Skip (Buf, Ptr); 74 else 75 Load_Integer (File, Buf, Stop); 76 end if; 77 78 Item := Scan_Integer (Buf, Ptr'Access, Stop); 79 Check_End_Of_Field (Buf, Stop, Ptr, Width); 80 end Get_Int; 81 82 ------------- 83 -- Get_LLI -- 84 ------------- 85 86 procedure Get_LLI 87 (File : File_Type; 88 Item : out Long_Long_Integer; 89 Width : Field) 90 is 91 Buf : String (1 .. Field'Last); 92 Ptr : aliased Integer := 1; 93 Stop : Integer := 0; 94 95 begin 96 if Width /= 0 then 97 Load_Width (File, Width, Buf, Stop); 98 String_Skip (Buf, Ptr); 99 else 100 Load_Integer (File, Buf, Stop); 101 end if; 102 103 Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); 104 Check_End_Of_Field (Buf, Stop, Ptr, Width); 105 end Get_LLI; 106 107 -------------- 108 -- Gets_Int -- 109 -------------- 110 111 procedure Gets_Int 112 (From : String; 113 Item : out Integer; 114 Last : out Positive) 115 is 116 Pos : aliased Integer; 117 118 begin 119 String_Skip (From, Pos); 120 Item := Scan_Integer (From, Pos'Access, From'Last); 121 Last := Pos - 1; 122 123 exception 124 when Constraint_Error => 125 raise Data_Error; 126 end Gets_Int; 127 128 -------------- 129 -- Gets_LLI -- 130 -------------- 131 132 procedure Gets_LLI 133 (From : String; 134 Item : out Long_Long_Integer; 135 Last : out Positive) 136 is 137 Pos : aliased Integer; 138 139 begin 140 String_Skip (From, Pos); 141 Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); 142 Last := Pos - 1; 143 144 exception 145 when Constraint_Error => 146 raise Data_Error; 147 end Gets_LLI; 148 149 ------------------ 150 -- Load_Integer -- 151 ------------------ 152 153 procedure Load_Integer 154 (File : File_Type; 155 Buf : out String; 156 Ptr : in out Natural) 157 is 158 Hash_Loc : Natural; 159 Loaded : Boolean; 160 161 begin 162 Load_Skip (File); 163 Load (File, Buf, Ptr, '+', '-'); 164 165 Load_Digits (File, Buf, Ptr, Loaded); 166 167 if Loaded then 168 169 -- Deal with based literal. We recognize either the standard '#' or 170 -- the allowed alternative replacement ':' (see RM J.2(3)). 171 172 Load (File, Buf, Ptr, '#', ':', Loaded); 173 174 if Loaded then 175 Hash_Loc := Ptr; 176 Load_Extended_Digits (File, Buf, Ptr); 177 Load (File, Buf, Ptr, Buf (Hash_Loc)); 178 end if; 179 180 -- Deal with exponent 181 182 Load (File, Buf, Ptr, 'E', 'e', Loaded); 183 184 if Loaded then 185 186 -- Note: it is strange to allow a minus sign, since the syntax 187 -- does not, but that is what ACVC test CE3704F, case (6) wants. 188 189 Load (File, Buf, Ptr, '+', '-'); 190 Load_Digits (File, Buf, Ptr); 191 end if; 192 end if; 193 end Load_Integer; 194 195 ------------- 196 -- Put_Int -- 197 ------------- 198 199 procedure Put_Int 200 (File : File_Type; 201 Item : Integer; 202 Width : Field; 203 Base : Number_Base) 204 is 205 Buf : String (1 .. Integer'Max (Field'Last, Width)); 206 Ptr : Natural := 0; 207 208 begin 209 if Base = 10 and then Width = 0 then 210 Set_Image_Integer (Item, Buf, Ptr); 211 elsif Base = 10 then 212 Set_Image_Width_Integer (Item, Width, Buf, Ptr); 213 else 214 Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); 215 end if; 216 217 Put_Item (File, Buf (1 .. Ptr)); 218 end Put_Int; 219 220 ------------- 221 -- Put_LLI -- 222 ------------- 223 224 procedure Put_LLI 225 (File : File_Type; 226 Item : Long_Long_Integer; 227 Width : Field; 228 Base : Number_Base) 229 is 230 Buf : String (1 .. Integer'Max (Field'Last, Width)); 231 Ptr : Natural := 0; 232 233 begin 234 if Base = 10 and then Width = 0 then 235 Set_Image_Long_Long_Integer (Item, Buf, Ptr); 236 elsif Base = 10 then 237 Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); 238 else 239 Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); 240 end if; 241 242 Put_Item (File, Buf (1 .. Ptr)); 243 end Put_LLI; 244 245 -------------- 246 -- Puts_Int -- 247 -------------- 248 249 procedure Puts_Int 250 (To : out String; 251 Item : Integer; 252 Base : Number_Base) 253 is 254 Buf : String (1 .. Integer'Max (Field'Last, To'Length)); 255 Ptr : Natural := 0; 256 257 begin 258 if Base = 10 then 259 Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); 260 else 261 Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); 262 end if; 263 264 if Ptr > To'Length then 265 raise Layout_Error; 266 else 267 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); 268 end if; 269 end Puts_Int; 270 271 -------------- 272 -- Puts_LLI -- 273 -------------- 274 275 procedure Puts_LLI 276 (To : out String; 277 Item : Long_Long_Integer; 278 Base : Number_Base) 279 is 280 Buf : String (1 .. Integer'Max (Field'Last, To'Length)); 281 Ptr : Natural := 0; 282 283 begin 284 if Base = 10 then 285 Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); 286 else 287 Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); 288 end if; 289 290 if Ptr > To'Length then 291 raise Layout_Error; 292 else 293 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); 294 end if; 295 end Puts_LLI; 296 297end Ada.Text_IO.Integer_Aux; 298