1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . T E X T _ I O . G E N E R I C _ 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 Interfaces.C_Streams; use Interfaces.C_Streams; 33with System.File_IO; 34with System.File_Control_Block; 35 36package body Ada.Text_IO.Generic_Aux is 37 38 package FIO renames System.File_IO; 39 package FCB renames System.File_Control_Block; 40 subtype AP is FCB.AFCB_Ptr; 41 42 ------------------------ 43 -- Check_End_Of_Field -- 44 ------------------------ 45 46 procedure Check_End_Of_Field 47 (Buf : String; 48 Stop : Integer; 49 Ptr : Integer; 50 Width : Field) 51 is 52 begin 53 if Ptr > Stop then 54 return; 55 56 elsif Width = 0 then 57 raise Data_Error; 58 59 else 60 for J in Ptr .. Stop loop 61 if not Is_Blank (Buf (J)) then 62 raise Data_Error; 63 end if; 64 end loop; 65 end if; 66 end Check_End_Of_Field; 67 68 ----------------------- 69 -- Check_On_One_Line -- 70 ----------------------- 71 72 procedure Check_On_One_Line 73 (File : File_Type; 74 Length : Integer) 75 is 76 begin 77 FIO.Check_Write_Status (AP (File)); 78 79 if File.Line_Length /= 0 then 80 if Count (Length) > File.Line_Length then 81 raise Layout_Error; 82 elsif File.Col + Count (Length) > File.Line_Length + 1 then 83 New_Line (File); 84 end if; 85 end if; 86 end Check_On_One_Line; 87 88 ---------- 89 -- Getc -- 90 ---------- 91 92 function Getc (File : File_Type) return int is 93 ch : int; 94 95 begin 96 ch := fgetc (File.Stream); 97 98 if ch = EOF and then ferror (File.Stream) /= 0 then 99 raise Device_Error; 100 else 101 return ch; 102 end if; 103 end Getc; 104 105 -------------- 106 -- Is_Blank -- 107 -------------- 108 109 function Is_Blank (C : Character) return Boolean is 110 begin 111 return C = ' ' or else C = ASCII.HT; 112 end Is_Blank; 113 114 ---------- 115 -- Load -- 116 ---------- 117 118 procedure Load 119 (File : File_Type; 120 Buf : out String; 121 Ptr : in out Integer; 122 Char : Character; 123 Loaded : out Boolean) 124 is 125 ch : int; 126 127 begin 128 ch := Getc (File); 129 130 if ch = Character'Pos (Char) then 131 Store_Char (File, ch, Buf, Ptr); 132 Loaded := True; 133 else 134 Ungetc (ch, File); 135 Loaded := False; 136 end if; 137 end Load; 138 139 procedure Load 140 (File : File_Type; 141 Buf : out String; 142 Ptr : in out Integer; 143 Char : Character) 144 is 145 ch : int; 146 147 begin 148 ch := Getc (File); 149 150 if ch = Character'Pos (Char) then 151 Store_Char (File, ch, Buf, Ptr); 152 else 153 Ungetc (ch, File); 154 end if; 155 end Load; 156 157 procedure Load 158 (File : File_Type; 159 Buf : out String; 160 Ptr : in out Integer; 161 Char1 : Character; 162 Char2 : Character; 163 Loaded : out Boolean) 164 is 165 ch : int; 166 167 begin 168 ch := Getc (File); 169 170 if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then 171 Store_Char (File, ch, Buf, Ptr); 172 Loaded := True; 173 else 174 Ungetc (ch, File); 175 Loaded := False; 176 end if; 177 end Load; 178 179 procedure Load 180 (File : File_Type; 181 Buf : out String; 182 Ptr : in out Integer; 183 Char1 : Character; 184 Char2 : Character) 185 is 186 ch : int; 187 188 begin 189 ch := Getc (File); 190 191 if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then 192 Store_Char (File, ch, Buf, Ptr); 193 else 194 Ungetc (ch, File); 195 end if; 196 end Load; 197 198 ----------------- 199 -- Load_Digits -- 200 ----------------- 201 202 procedure Load_Digits 203 (File : File_Type; 204 Buf : out String; 205 Ptr : in out Integer; 206 Loaded : out Boolean) 207 is 208 ch : int; 209 After_Digit : Boolean; 210 211 begin 212 ch := Getc (File); 213 214 if ch not in Character'Pos ('0') .. Character'Pos ('9') then 215 Loaded := False; 216 217 else 218 Loaded := True; 219 After_Digit := True; 220 221 loop 222 Store_Char (File, ch, Buf, Ptr); 223 ch := Getc (File); 224 225 if ch in Character'Pos ('0') .. Character'Pos ('9') then 226 After_Digit := True; 227 228 elsif ch = Character'Pos ('_') and then After_Digit then 229 After_Digit := False; 230 231 else 232 exit; 233 end if; 234 end loop; 235 end if; 236 237 Ungetc (ch, File); 238 end Load_Digits; 239 240 procedure Load_Digits 241 (File : File_Type; 242 Buf : out String; 243 Ptr : in out Integer) 244 is 245 ch : int; 246 After_Digit : Boolean; 247 248 begin 249 ch := Getc (File); 250 251 if ch in Character'Pos ('0') .. Character'Pos ('9') then 252 After_Digit := True; 253 254 loop 255 Store_Char (File, ch, Buf, Ptr); 256 ch := Getc (File); 257 258 if ch in Character'Pos ('0') .. Character'Pos ('9') then 259 After_Digit := True; 260 261 elsif ch = Character'Pos ('_') and then After_Digit then 262 After_Digit := False; 263 264 else 265 exit; 266 end if; 267 end loop; 268 end if; 269 270 Ungetc (ch, File); 271 end Load_Digits; 272 273 -------------------------- 274 -- Load_Extended_Digits -- 275 -------------------------- 276 277 procedure Load_Extended_Digits 278 (File : File_Type; 279 Buf : out String; 280 Ptr : in out Integer; 281 Loaded : out Boolean) 282 is 283 ch : int; 284 After_Digit : Boolean := False; 285 286 begin 287 Loaded := False; 288 289 loop 290 ch := Getc (File); 291 292 if ch in Character'Pos ('0') .. Character'Pos ('9') 293 or else 294 ch in Character'Pos ('a') .. Character'Pos ('f') 295 or else 296 ch in Character'Pos ('A') .. Character'Pos ('F') 297 then 298 After_Digit := True; 299 300 elsif ch = Character'Pos ('_') and then After_Digit then 301 After_Digit := False; 302 303 else 304 exit; 305 end if; 306 307 Store_Char (File, ch, Buf, Ptr); 308 Loaded := True; 309 end loop; 310 311 Ungetc (ch, File); 312 end Load_Extended_Digits; 313 314 procedure Load_Extended_Digits 315 (File : File_Type; 316 Buf : out String; 317 Ptr : in out Integer) 318 is 319 Junk : Boolean; 320 pragma Unreferenced (Junk); 321 begin 322 Load_Extended_Digits (File, Buf, Ptr, Junk); 323 end Load_Extended_Digits; 324 325 --------------- 326 -- Load_Skip -- 327 --------------- 328 329 procedure Load_Skip (File : File_Type) is 330 C : Character; 331 332 begin 333 FIO.Check_Read_Status (AP (File)); 334 335 -- Loop till we find a non-blank character (note that as usual in 336 -- Text_IO, blank includes horizontal tab). Note that Get deals with 337 -- the Before_LM and Before_LM_PM flags appropriately. 338 339 loop 340 Get (File, C); 341 exit when not Is_Blank (C); 342 end loop; 343 344 Ungetc (Character'Pos (C), File); 345 File.Col := File.Col - 1; 346 end Load_Skip; 347 348 ---------------- 349 -- Load_Width -- 350 ---------------- 351 352 procedure Load_Width 353 (File : File_Type; 354 Width : Field; 355 Buf : out String; 356 Ptr : in out Integer) 357 is 358 ch : int; 359 360 begin 361 FIO.Check_Read_Status (AP (File)); 362 363 -- If we are immediately before a line mark, then we have no characters. 364 -- This is always a data error, so we may as well raise it right away. 365 366 if File.Before_LM then 367 raise Data_Error; 368 369 else 370 for J in 1 .. Width loop 371 ch := Getc (File); 372 373 if ch = EOF then 374 return; 375 376 elsif ch = LM then 377 Ungetc (ch, File); 378 return; 379 380 else 381 Store_Char (File, ch, Buf, Ptr); 382 end if; 383 end loop; 384 end if; 385 end Load_Width; 386 387 ----------- 388 -- Nextc -- 389 ----------- 390 391 function Nextc (File : File_Type) return int is 392 ch : int; 393 394 begin 395 ch := fgetc (File.Stream); 396 397 if ch = EOF then 398 if ferror (File.Stream) /= 0 then 399 raise Device_Error; 400 else 401 return EOF; 402 end if; 403 404 else 405 Ungetc (ch, File); 406 return ch; 407 end if; 408 end Nextc; 409 410 -------------- 411 -- Put_Item -- 412 -------------- 413 414 procedure Put_Item (File : File_Type; Str : String) is 415 begin 416 Check_On_One_Line (File, Str'Length); 417 Put (File, Str); 418 end Put_Item; 419 420 ---------------- 421 -- Store_Char -- 422 ---------------- 423 424 procedure Store_Char 425 (File : File_Type; 426 ch : int; 427 Buf : in out String; 428 Ptr : in out Integer) 429 is 430 begin 431 File.Col := File.Col + 1; 432 433 if Ptr < Buf'Last then 434 Ptr := Ptr + 1; 435 end if; 436 437 Buf (Ptr) := Character'Val (ch); 438 end Store_Char; 439 440 ----------------- 441 -- String_Skip -- 442 ----------------- 443 444 procedure String_Skip (Str : String; Ptr : out Integer) is 445 begin 446 Ptr := Str'First; 447 448 loop 449 if Ptr > Str'Last then 450 raise End_Error; 451 452 elsif not Is_Blank (Str (Ptr)) then 453 return; 454 455 else 456 Ptr := Ptr + 1; 457 end if; 458 end loop; 459 end String_Skip; 460 461 ------------ 462 -- Ungetc -- 463 ------------ 464 465 procedure Ungetc (ch : int; File : File_Type) is 466 begin 467 if ch /= EOF then 468 if ungetc (ch, File.Stream) = EOF then 469 raise Device_Error; 470 end if; 471 end if; 472 end Ungetc; 473 474end Ada.Text_IO.Generic_Aux; 475