1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ 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-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-- 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.Wide_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 -- Is_Blank -- 90 -------------- 91 92 function Is_Blank (C : Character) return Boolean is 93 begin 94 return C = ' ' or else C = ASCII.HT; 95 end Is_Blank; 96 97 ---------- 98 -- Load -- 99 ---------- 100 101 procedure Load 102 (File : File_Type; 103 Buf : out String; 104 Ptr : in out Integer; 105 Char : Character; 106 Loaded : out Boolean) 107 is 108 ch : int; 109 110 begin 111 if File.Before_Wide_Character then 112 Loaded := False; 113 return; 114 115 else 116 ch := Getc (File); 117 118 if ch = Character'Pos (Char) then 119 Store_Char (File, ch, Buf, Ptr); 120 Loaded := True; 121 else 122 Ungetc (ch, File); 123 Loaded := False; 124 end if; 125 end if; 126 end Load; 127 128 procedure Load 129 (File : File_Type; 130 Buf : out String; 131 Ptr : in out Integer; 132 Char : Character) 133 is 134 ch : int; 135 136 begin 137 if File.Before_Wide_Character then 138 null; 139 140 else 141 ch := Getc (File); 142 143 if ch = Character'Pos (Char) then 144 Store_Char (File, ch, Buf, Ptr); 145 else 146 Ungetc (ch, File); 147 end if; 148 end if; 149 end Load; 150 151 procedure Load 152 (File : File_Type; 153 Buf : out String; 154 Ptr : in out Integer; 155 Char1 : Character; 156 Char2 : Character; 157 Loaded : out Boolean) 158 is 159 ch : int; 160 161 begin 162 if File.Before_Wide_Character then 163 Loaded := False; 164 return; 165 166 else 167 ch := Getc (File); 168 169 if ch = Character'Pos (Char1) 170 or else ch = Character'Pos (Char2) 171 then 172 Store_Char (File, ch, Buf, Ptr); 173 Loaded := True; 174 else 175 Ungetc (ch, File); 176 Loaded := False; 177 end if; 178 end if; 179 end Load; 180 181 procedure Load 182 (File : File_Type; 183 Buf : out String; 184 Ptr : in out Integer; 185 Char1 : Character; 186 Char2 : Character) 187 is 188 ch : int; 189 190 begin 191 if File.Before_Wide_Character then 192 null; 193 194 else 195 ch := Getc (File); 196 197 if ch = Character'Pos (Char1) 198 or else ch = Character'Pos (Char2) 199 then 200 Store_Char (File, ch, Buf, Ptr); 201 else 202 Ungetc (ch, File); 203 end if; 204 end if; 205 end Load; 206 207 ----------------- 208 -- Load_Digits -- 209 ----------------- 210 211 procedure Load_Digits 212 (File : File_Type; 213 Buf : out String; 214 Ptr : in out Integer; 215 Loaded : out Boolean) 216 is 217 ch : int; 218 After_Digit : Boolean; 219 220 begin 221 if File.Before_Wide_Character then 222 Loaded := False; 223 return; 224 225 else 226 ch := Getc (File); 227 228 if ch not in Character'Pos ('0') .. Character'Pos ('9') then 229 Loaded := False; 230 231 else 232 Loaded := True; 233 After_Digit := True; 234 235 loop 236 Store_Char (File, ch, Buf, Ptr); 237 ch := Getc (File); 238 239 if ch in Character'Pos ('0') .. Character'Pos ('9') then 240 After_Digit := True; 241 242 elsif ch = Character'Pos ('_') and then After_Digit then 243 After_Digit := False; 244 245 else 246 exit; 247 end if; 248 end loop; 249 end if; 250 251 Ungetc (ch, File); 252 end if; 253 end Load_Digits; 254 255 procedure Load_Digits 256 (File : File_Type; 257 Buf : out String; 258 Ptr : in out Integer) 259 is 260 ch : int; 261 After_Digit : Boolean; 262 263 begin 264 if File.Before_Wide_Character then 265 return; 266 267 else 268 ch := Getc (File); 269 270 if ch in Character'Pos ('0') .. Character'Pos ('9') then 271 After_Digit := True; 272 273 loop 274 Store_Char (File, ch, Buf, Ptr); 275 ch := Getc (File); 276 277 if ch in Character'Pos ('0') .. Character'Pos ('9') then 278 After_Digit := True; 279 280 elsif ch = Character'Pos ('_') and then After_Digit then 281 After_Digit := False; 282 283 else 284 exit; 285 end if; 286 end loop; 287 end if; 288 289 Ungetc (ch, File); 290 end if; 291 end Load_Digits; 292 293 -------------------------- 294 -- Load_Extended_Digits -- 295 -------------------------- 296 297 procedure Load_Extended_Digits 298 (File : File_Type; 299 Buf : out String; 300 Ptr : in out Integer; 301 Loaded : out Boolean) 302 is 303 ch : int; 304 After_Digit : Boolean := False; 305 306 begin 307 if File.Before_Wide_Character then 308 Loaded := False; 309 return; 310 311 else 312 Loaded := False; 313 314 loop 315 ch := Getc (File); 316 317 if ch in Character'Pos ('0') .. Character'Pos ('9') 318 or else 319 ch in Character'Pos ('a') .. Character'Pos ('f') 320 or else 321 ch in Character'Pos ('A') .. Character'Pos ('F') 322 then 323 After_Digit := True; 324 325 elsif ch = Character'Pos ('_') and then After_Digit then 326 After_Digit := False; 327 328 else 329 exit; 330 end if; 331 332 Store_Char (File, ch, Buf, Ptr); 333 Loaded := True; 334 end loop; 335 336 Ungetc (ch, File); 337 end if; 338 end Load_Extended_Digits; 339 340 procedure Load_Extended_Digits 341 (File : File_Type; 342 Buf : out String; 343 Ptr : in out Integer) 344 is 345 Junk : Boolean; 346 pragma Unreferenced (Junk); 347 begin 348 Load_Extended_Digits (File, Buf, Ptr, Junk); 349 end Load_Extended_Digits; 350 351 --------------- 352 -- Load_Skip -- 353 --------------- 354 355 procedure Load_Skip (File : File_Type) is 356 C : Character; 357 358 begin 359 FIO.Check_Read_Status (AP (File)); 360 361 -- We need to explicitly test for the case of being before a wide 362 -- character (greater than 16#7F#). Since no such character can 363 -- ever legitimately be a valid numeric character, we can 364 -- immediately signal Data_Error. 365 366 if File.Before_Wide_Character then 367 raise Data_Error; 368 end if; 369 370 -- Otherwise loop till we find a non-blank character (note that as 371 -- usual in Wide_Text_IO, blank includes horizontal tab). Note that 372 -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. 373 374 loop 375 Get_Character (File, C); 376 exit when not Is_Blank (C); 377 end loop; 378 379 Ungetc (Character'Pos (C), File); 380 File.Col := File.Col - 1; 381 end Load_Skip; 382 383 ---------------- 384 -- Load_Width -- 385 ---------------- 386 387 procedure Load_Width 388 (File : File_Type; 389 Width : Field; 390 Buf : out String; 391 Ptr : in out Integer) 392 is 393 ch : int; 394 WC : Wide_Character; 395 396 Bad_Wide_C : Boolean := False; 397 -- Set True if one of the characters read is not in range of type 398 -- Character. This is always a Data_Error, but we do not signal it 399 -- right away, since we have to read the full number of characters. 400 401 begin 402 FIO.Check_Read_Status (AP (File)); 403 404 -- If we are immediately before a line mark, then we have no characters. 405 -- This is always a data error, so we may as well raise it right away. 406 407 if File.Before_LM then 408 raise Data_Error; 409 410 else 411 for J in 1 .. Width loop 412 if File.Before_Wide_Character then 413 Bad_Wide_C := True; 414 Store_Char (File, 0, Buf, Ptr); 415 File.Before_Wide_Character := False; 416 417 else 418 ch := Getc (File); 419 420 if ch = EOF then 421 exit; 422 423 elsif ch = LM then 424 Ungetc (ch, File); 425 exit; 426 427 else 428 WC := Get_Wide_Char (Character'Val (ch), File); 429 ch := Wide_Character'Pos (WC); 430 431 if ch > 255 then 432 Bad_Wide_C := True; 433 ch := 0; 434 end if; 435 436 Store_Char (File, ch, Buf, Ptr); 437 end if; 438 end if; 439 end loop; 440 441 if Bad_Wide_C then 442 raise Data_Error; 443 end if; 444 end if; 445 end Load_Width; 446 447 -------------- 448 -- Put_Item -- 449 -------------- 450 451 procedure Put_Item (File : File_Type; Str : String) is 452 begin 453 Check_On_One_Line (File, Str'Length); 454 455 for J in Str'Range loop 456 Put (File, Wide_Character'Val (Character'Pos (Str (J)))); 457 end loop; 458 end Put_Item; 459 460 ---------------- 461 -- Store_Char -- 462 ---------------- 463 464 procedure Store_Char 465 (File : File_Type; 466 ch : Integer; 467 Buf : out String; 468 Ptr : in out Integer) 469 is 470 begin 471 File.Col := File.Col + 1; 472 473 if Ptr = Buf'Last then 474 raise Data_Error; 475 else 476 Ptr := Ptr + 1; 477 Buf (Ptr) := Character'Val (ch); 478 end if; 479 end Store_Char; 480 481 ----------------- 482 -- String_Skip -- 483 ----------------- 484 485 procedure String_Skip (Str : String; Ptr : out Integer) is 486 begin 487 -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. 488 -- It's too much trouble to make this silly case work, so we just raise 489 -- Program_Error with an appropriate message. We raise Program_Error 490 -- rather than Constraint_Error because we don't want this case to be 491 -- converted to Data_Error. 492 493 if Str'Last = Positive'Last then 494 raise Program_Error with 495 "string upper bound is Positive'Last, not supported"; 496 end if; 497 498 -- Normal case where Str'Last < Positive'Last 499 500 Ptr := Str'First; 501 502 loop 503 if Ptr > Str'Last then 504 raise End_Error; 505 506 elsif not Is_Blank (Str (Ptr)) then 507 return; 508 509 else 510 Ptr := Ptr + 1; 511 end if; 512 end loop; 513 end String_Skip; 514 515 ------------ 516 -- Ungetc -- 517 ------------ 518 519 procedure Ungetc (ch : int; File : File_Type) is 520 begin 521 if ch /= EOF then 522 if ungetc (ch, File.Stream) = EOF then 523 raise Device_Error; 524 end if; 525 end if; 526 end Ungetc; 527 528end Ada.Wide_Text_IO.Generic_Aux; 529