1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . T E X T _ I O . M O D U L A R _ A U X -- 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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; 33 34with System.Img_BIU; use System.Img_BIU; 35with System.Img_Uns; use System.Img_Uns; 36with System.Img_LLB; use System.Img_LLB; 37with System.Img_LLU; use System.Img_LLU; 38with System.Img_LLW; use System.Img_LLW; 39with System.Img_WIU; use System.Img_WIU; 40with System.Val_Uns; use System.Val_Uns; 41with System.Val_LLU; use System.Val_LLU; 42 43package body Ada.Text_IO.Modular_Aux is 44 45 use System.Unsigned_Types; 46 47 ----------------------- 48 -- Local Subprograms -- 49 ----------------------- 50 51 procedure Load_Modular 52 (File : File_Type; 53 Buf : out String; 54 Ptr : in out Natural); 55 -- This is an auxiliary routine that is used to load an possibly signed 56 -- modular literal value from the input file into Buf, starting at Ptr + 1. 57 -- Ptr is left set to the last character stored. 58 59 ------------- 60 -- Get_LLU -- 61 ------------- 62 63 procedure Get_LLU 64 (File : File_Type; 65 Item : out Long_Long_Unsigned; 66 Width : Field) 67 is 68 Buf : String (1 .. Field'Last); 69 Stop : Integer := 0; 70 Ptr : aliased Integer := 1; 71 72 begin 73 if Width /= 0 then 74 Load_Width (File, Width, Buf, Stop); 75 String_Skip (Buf, Ptr); 76 else 77 Load_Modular (File, Buf, Stop); 78 end if; 79 80 Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); 81 Check_End_Of_Field (Buf, Stop, Ptr, Width); 82 end Get_LLU; 83 84 ------------- 85 -- Get_Uns -- 86 ------------- 87 88 procedure Get_Uns 89 (File : File_Type; 90 Item : out Unsigned; 91 Width : Field) 92 is 93 Buf : String (1 .. Field'Last); 94 Stop : Integer := 0; 95 Ptr : aliased Integer := 1; 96 97 begin 98 if Width /= 0 then 99 Load_Width (File, Width, Buf, Stop); 100 String_Skip (Buf, Ptr); 101 else 102 Load_Modular (File, Buf, Stop); 103 end if; 104 105 Item := Scan_Unsigned (Buf, Ptr'Access, Stop); 106 Check_End_Of_Field (Buf, Stop, Ptr, Width); 107 end Get_Uns; 108 109 -------------- 110 -- Gets_LLU -- 111 -------------- 112 113 procedure Gets_LLU 114 (From : String; 115 Item : out Long_Long_Unsigned; 116 Last : out Positive) 117 is 118 Pos : aliased Integer; 119 120 begin 121 String_Skip (From, Pos); 122 Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); 123 Last := Pos - 1; 124 125 exception 126 when Constraint_Error => 127 raise Data_Error; 128 end Gets_LLU; 129 130 -------------- 131 -- Gets_Uns -- 132 -------------- 133 134 procedure Gets_Uns 135 (From : String; 136 Item : out Unsigned; 137 Last : out Positive) 138 is 139 Pos : aliased Integer; 140 141 begin 142 String_Skip (From, Pos); 143 Item := Scan_Unsigned (From, Pos'Access, From'Last); 144 Last := Pos - 1; 145 146 exception 147 when Constraint_Error => 148 raise Data_Error; 149 end Gets_Uns; 150 151 ------------------ 152 -- Load_Modular -- 153 ------------------ 154 155 procedure Load_Modular 156 (File : File_Type; 157 Buf : out String; 158 Ptr : in out Natural) 159 is 160 Hash_Loc : Natural; 161 Loaded : Boolean; 162 163 begin 164 Load_Skip (File); 165 166 -- Note: it is a bit strange to allow a minus sign here, but it seems 167 -- consistent with the general behavior expected by the ACVC tests 168 -- which is to scan past junk and then signal data error, see ACVC 169 -- test CE3704F, case (6), which is for signed integer exponents, 170 -- which seems a similar case. 171 172 Load (File, Buf, Ptr, '+', '-'); 173 Load_Digits (File, Buf, Ptr, Loaded); 174 175 if Loaded then 176 Load (File, Buf, Ptr, '#', ':', Loaded); 177 178 if Loaded then 179 Hash_Loc := Ptr; 180 Load_Extended_Digits (File, Buf, Ptr); 181 Load (File, Buf, Ptr, Buf (Hash_Loc)); 182 end if; 183 184 Load (File, Buf, Ptr, 'E', 'e', Loaded); 185 186 if Loaded then 187 188 -- Note: it is strange to allow a minus sign, since the syntax 189 -- does not, but that is what ACVC test CE3704F, case (6) wants 190 -- for the signed case, and there seems no good reason to treat 191 -- exponents differently for the signed and unsigned cases. 192 193 Load (File, Buf, Ptr, '+', '-'); 194 Load_Digits (File, Buf, Ptr); 195 end if; 196 end if; 197 end Load_Modular; 198 199 ------------- 200 -- Put_LLU -- 201 ------------- 202 203 procedure Put_LLU 204 (File : File_Type; 205 Item : Long_Long_Unsigned; 206 Width : Field; 207 Base : Number_Base) 208 is 209 Buf : String (1 .. Field'Last); 210 Ptr : Natural := 0; 211 212 begin 213 if Base = 10 and then Width = 0 then 214 Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); 215 elsif Base = 10 then 216 Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); 217 else 218 Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); 219 end if; 220 221 Put_Item (File, Buf (1 .. Ptr)); 222 end Put_LLU; 223 224 ------------- 225 -- Put_Uns -- 226 ------------- 227 228 procedure Put_Uns 229 (File : File_Type; 230 Item : Unsigned; 231 Width : Field; 232 Base : Number_Base) 233 is 234 Buf : String (1 .. Field'Last); 235 Ptr : Natural := 0; 236 237 begin 238 if Base = 10 and then Width = 0 then 239 Set_Image_Unsigned (Item, Buf, Ptr); 240 elsif Base = 10 then 241 Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); 242 else 243 Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); 244 end if; 245 246 Put_Item (File, Buf (1 .. Ptr)); 247 end Put_Uns; 248 249 -------------- 250 -- Puts_LLU -- 251 -------------- 252 253 procedure Puts_LLU 254 (To : out String; 255 Item : Long_Long_Unsigned; 256 Base : Number_Base) 257 is 258 Buf : String (1 .. Field'Last); 259 Ptr : Natural := 0; 260 261 begin 262 if Base = 10 then 263 Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); 264 else 265 Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); 266 end if; 267 268 if Ptr > To'Length then 269 raise Layout_Error; 270 else 271 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); 272 end if; 273 end Puts_LLU; 274 275 -------------- 276 -- Puts_Uns -- 277 -------------- 278 279 procedure Puts_Uns 280 (To : out String; 281 Item : Unsigned; 282 Base : Number_Base) 283 is 284 Buf : String (1 .. Field'Last); 285 Ptr : Natural := 0; 286 287 begin 288 if Base = 10 then 289 Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); 290 else 291 Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); 292 end if; 293 294 if Ptr > To'Length then 295 raise Layout_Error; 296 else 297 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); 298 end if; 299 end Puts_Uns; 300 301end Ada.Text_IO.Modular_Aux; 302