1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2008-2010, 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 32pragma Compiler_Unit; 33 34with Ada.Streams; use Ada.Streams; 35with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; 36with Ada.Unchecked_Conversion; 37 38with System.Stream_Attributes; use System; 39 40package body System.Strings.Stream_Ops is 41 42 -- The following type describes the low-level IO mechanism used in package 43 -- Stream_Ops_Internal. 44 45 type IO_Kind is (Byte_IO, Block_IO); 46 47 -- The following package provides an IO framework for strings. Depending 48 -- on the version of System.Stream_Attributes as well as the size of 49 -- formal parameter Character_Type, the package will either utilize block 50 -- IO or character-by-character IO. 51 52 generic 53 type Character_Type is private; 54 type String_Type is array (Positive range <>) of Character_Type; 55 56 package Stream_Ops_Internal is 57 function Input 58 (Strm : access Root_Stream_Type'Class; 59 IO : IO_Kind) return String_Type; 60 61 procedure Output 62 (Strm : access Root_Stream_Type'Class; 63 Item : String_Type; 64 IO : IO_Kind); 65 66 procedure Read 67 (Strm : access Root_Stream_Type'Class; 68 Item : out String_Type; 69 IO : IO_Kind); 70 71 procedure Write 72 (Strm : access Root_Stream_Type'Class; 73 Item : String_Type; 74 IO : IO_Kind); 75 end Stream_Ops_Internal; 76 77 ------------------------- 78 -- Stream_Ops_Internal -- 79 ------------------------- 80 81 package body Stream_Ops_Internal is 82 83 -- The following value represents the number of BITS allocated for the 84 -- default block used in string IO. The sizes of all other types are 85 -- calculated relative to this value. 86 87 Default_Block_Size : constant := 512 * 8; 88 89 -- Shorthand notation for stream element and character sizes 90 91 C_Size : constant Integer := Character_Type'Size; 92 SE_Size : constant Integer := Stream_Element'Size; 93 94 -- The following constants describe the number of stream elements or 95 -- characters that can fit into a default block. 96 97 C_In_Default_Block : constant Integer := Default_Block_Size / C_Size; 98 SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; 99 100 -- Buffer types 101 102 subtype Default_Block is Stream_Element_Array 103 (1 .. Stream_Element_Offset (SE_In_Default_Block)); 104 105 subtype String_Block is String_Type (1 .. C_In_Default_Block); 106 107 -- Conversions to and from Default_Block 108 109 function To_Default_Block is 110 new Ada.Unchecked_Conversion (String_Block, Default_Block); 111 112 function To_String_Block is 113 new Ada.Unchecked_Conversion (Default_Block, String_Block); 114 115 ----------- 116 -- Input -- 117 ----------- 118 119 function Input 120 (Strm : access Root_Stream_Type'Class; 121 IO : IO_Kind) return String_Type 122 is 123 begin 124 if Strm = null then 125 raise Constraint_Error; 126 end if; 127 128 declare 129 Low : Positive; 130 High : Positive; 131 132 begin 133 -- Read the bounds of the string 134 135 Positive'Read (Strm, Low); 136 Positive'Read (Strm, High); 137 138 declare 139 Item : String_Type (Low .. High); 140 141 begin 142 -- Read the character content of the string 143 144 Read (Strm, Item, IO); 145 146 return Item; 147 end; 148 end; 149 end Input; 150 151 ------------ 152 -- Output -- 153 ------------ 154 155 procedure Output 156 (Strm : access Root_Stream_Type'Class; 157 Item : String_Type; 158 IO : IO_Kind) 159 is 160 begin 161 if Strm = null then 162 raise Constraint_Error; 163 end if; 164 165 -- Write the bounds of the string 166 167 Positive'Write (Strm, Item'First); 168 Positive'Write (Strm, Item'Last); 169 170 -- Write the character content of the string 171 172 Write (Strm, Item, IO); 173 end Output; 174 175 ---------- 176 -- Read -- 177 ---------- 178 179 procedure Read 180 (Strm : access Root_Stream_Type'Class; 181 Item : out String_Type; 182 IO : IO_Kind) 183 is 184 begin 185 if Strm = null then 186 raise Constraint_Error; 187 end if; 188 189 -- Nothing to do if the desired string is empty 190 191 if Item'Length = 0 then 192 return; 193 end if; 194 195 -- Block IO 196 197 if IO = Block_IO 198 and then Stream_Attributes.Block_IO_OK 199 then 200 declare 201 -- Determine the size in BITS of the block necessary to contain 202 -- the whole string. 203 204 Block_Size : constant Natural := 205 (Item'Last - Item'First + 1) * C_Size; 206 207 -- Item can be larger than what the default block can store, 208 -- determine the number of whole reads necessary to read the 209 -- string. 210 211 Blocks : constant Natural := Block_Size / Default_Block_Size; 212 213 -- The size of Item may not be a multiple of the default block 214 -- size, determine the size of the remaining chunk in BITS. 215 216 Rem_Size : constant Natural := 217 Block_Size mod Default_Block_Size; 218 219 -- String indexes 220 221 Low : Positive := Item'First; 222 High : Positive := Low + C_In_Default_Block - 1; 223 224 -- End of stream error detection 225 226 Last : Stream_Element_Offset := 0; 227 Sum : Stream_Element_Offset := 0; 228 229 begin 230 -- Step 1: If the string is too large, read in individual 231 -- chunks the size of the default block. 232 233 if Blocks > 0 then 234 declare 235 Block : Default_Block; 236 237 begin 238 for Counter in 1 .. Blocks loop 239 Read (Strm.all, Block, Last); 240 Item (Low .. High) := To_String_Block (Block); 241 242 Low := High + 1; 243 High := Low + C_In_Default_Block - 1; 244 Sum := Sum + Last; 245 Last := 0; 246 end loop; 247 end; 248 end if; 249 250 -- Step 2: Read in any remaining elements 251 252 if Rem_Size > 0 then 253 declare 254 subtype Rem_Block is Stream_Element_Array 255 (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); 256 257 subtype Rem_String_Block is 258 String_Type (1 .. Rem_Size / C_Size); 259 260 function To_Rem_String_Block is new 261 Ada.Unchecked_Conversion (Rem_Block, Rem_String_Block); 262 263 Block : Rem_Block; 264 265 begin 266 Read (Strm.all, Block, Last); 267 Item (Low .. Item'Last) := To_Rem_String_Block (Block); 268 269 Sum := Sum + Last; 270 end; 271 end if; 272 273 -- Step 3: Potential error detection. The sum of all the 274 -- chunks is less than we initially wanted to read. In other 275 -- words, the stream does not contain enough elements to fully 276 -- populate Item. 277 278 if (Integer (Sum) * SE_Size) / C_Size < Item'Length then 279 raise End_Error; 280 end if; 281 end; 282 283 -- Byte IO 284 285 else 286 declare 287 C : Character_Type; 288 289 begin 290 for Index in Item'First .. Item'Last loop 291 Character_Type'Read (Strm, C); 292 Item (Index) := C; 293 end loop; 294 end; 295 end if; 296 end Read; 297 298 ----------- 299 -- Write -- 300 ----------- 301 302 procedure Write 303 (Strm : access Root_Stream_Type'Class; 304 Item : String_Type; 305 IO : IO_Kind) 306 is 307 begin 308 if Strm = null then 309 raise Constraint_Error; 310 end if; 311 312 -- Nothing to do if the input string is empty 313 314 if Item'Length = 0 then 315 return; 316 end if; 317 318 -- Block IO 319 320 if IO = Block_IO 321 and then Stream_Attributes.Block_IO_OK 322 then 323 declare 324 -- Determine the size in BITS of the block necessary to contain 325 -- the whole string. 326 327 Block_Size : constant Natural := Item'Length * C_Size; 328 329 -- Item can be larger than what the default block can store, 330 -- determine the number of whole writes necessary to output the 331 -- string. 332 333 Blocks : constant Natural := Block_Size / Default_Block_Size; 334 335 -- The size of Item may not be a multiple of the default block 336 -- size, determine the size of the remaining chunk. 337 338 Rem_Size : constant Natural := 339 Block_Size mod Default_Block_Size; 340 341 -- String indexes 342 343 Low : Positive := Item'First; 344 High : Positive := Low + C_In_Default_Block - 1; 345 346 begin 347 -- Step 1: If the string is too large, write out individual 348 -- chunks the size of the default block. 349 350 for Counter in 1 .. Blocks loop 351 Write (Strm.all, To_Default_Block (Item (Low .. High))); 352 353 Low := High + 1; 354 High := Low + C_In_Default_Block - 1; 355 end loop; 356 357 -- Step 2: Write out any remaining elements 358 359 if Rem_Size > 0 then 360 declare 361 subtype Rem_Block is Stream_Element_Array 362 (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); 363 364 subtype Rem_String_Block is 365 String_Type (1 .. Rem_Size / C_Size); 366 367 function To_Rem_Block is new 368 Ada.Unchecked_Conversion (Rem_String_Block, Rem_Block); 369 370 begin 371 Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); 372 end; 373 end if; 374 end; 375 376 -- Byte IO 377 378 else 379 for Index in Item'First .. Item'Last loop 380 Character_Type'Write (Strm, Item (Index)); 381 end loop; 382 end if; 383 end Write; 384 end Stream_Ops_Internal; 385 386 -- Specific instantiations for all Ada string types 387 388 package String_Ops is 389 new Stream_Ops_Internal 390 (Character_Type => Character, 391 String_Type => String); 392 393 package Wide_String_Ops is 394 new Stream_Ops_Internal 395 (Character_Type => Wide_Character, 396 String_Type => Wide_String); 397 398 package Wide_Wide_String_Ops is 399 new Stream_Ops_Internal 400 (Character_Type => Wide_Wide_Character, 401 String_Type => Wide_Wide_String); 402 403 ------------------ 404 -- String_Input -- 405 ------------------ 406 407 function String_Input 408 (Strm : access Ada.Streams.Root_Stream_Type'Class) return String 409 is 410 begin 411 return String_Ops.Input (Strm, Byte_IO); 412 end String_Input; 413 414 ------------------------- 415 -- String_Input_Blk_IO -- 416 ------------------------- 417 418 function String_Input_Blk_IO 419 (Strm : access Ada.Streams.Root_Stream_Type'Class) return String 420 is 421 begin 422 return String_Ops.Input (Strm, Block_IO); 423 end String_Input_Blk_IO; 424 425 ------------------- 426 -- String_Output -- 427 ------------------- 428 429 procedure String_Output 430 (Strm : access Ada.Streams.Root_Stream_Type'Class; 431 Item : String) 432 is 433 begin 434 String_Ops.Output (Strm, Item, Byte_IO); 435 end String_Output; 436 437 -------------------------- 438 -- String_Output_Blk_IO -- 439 -------------------------- 440 441 procedure String_Output_Blk_IO 442 (Strm : access Ada.Streams.Root_Stream_Type'Class; 443 Item : String) 444 is 445 begin 446 String_Ops.Output (Strm, Item, Block_IO); 447 end String_Output_Blk_IO; 448 449 ----------------- 450 -- String_Read -- 451 ----------------- 452 453 procedure String_Read 454 (Strm : access Ada.Streams.Root_Stream_Type'Class; 455 Item : out String) 456 is 457 begin 458 String_Ops.Read (Strm, Item, Byte_IO); 459 end String_Read; 460 461 ------------------------ 462 -- String_Read_Blk_IO -- 463 ------------------------ 464 465 procedure String_Read_Blk_IO 466 (Strm : access Ada.Streams.Root_Stream_Type'Class; 467 Item : out String) 468 is 469 begin 470 String_Ops.Read (Strm, Item, Block_IO); 471 end String_Read_Blk_IO; 472 473 ------------------ 474 -- String_Write -- 475 ------------------ 476 477 procedure String_Write 478 (Strm : access Ada.Streams.Root_Stream_Type'Class; 479 Item : String) 480 is 481 begin 482 String_Ops.Write (Strm, Item, Byte_IO); 483 end String_Write; 484 485 ------------------------- 486 -- String_Write_Blk_IO -- 487 ------------------------- 488 489 procedure String_Write_Blk_IO 490 (Strm : access Ada.Streams.Root_Stream_Type'Class; 491 Item : String) 492 is 493 begin 494 String_Ops.Write (Strm, Item, Block_IO); 495 end String_Write_Blk_IO; 496 497 ----------------------- 498 -- Wide_String_Input -- 499 ----------------------- 500 501 function Wide_String_Input 502 (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String 503 is 504 begin 505 return Wide_String_Ops.Input (Strm, Byte_IO); 506 end Wide_String_Input; 507 508 ------------------------------ 509 -- Wide_String_Input_Blk_IO -- 510 ------------------------------ 511 512 function Wide_String_Input_Blk_IO 513 (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String 514 is 515 begin 516 return Wide_String_Ops.Input (Strm, Block_IO); 517 end Wide_String_Input_Blk_IO; 518 519 ------------------------ 520 -- Wide_String_Output -- 521 ------------------------ 522 523 procedure Wide_String_Output 524 (Strm : access Ada.Streams.Root_Stream_Type'Class; 525 Item : Wide_String) 526 is 527 begin 528 Wide_String_Ops.Output (Strm, Item, Byte_IO); 529 end Wide_String_Output; 530 531 ------------------------------- 532 -- Wide_String_Output_Blk_IO -- 533 ------------------------------- 534 535 procedure Wide_String_Output_Blk_IO 536 (Strm : access Ada.Streams.Root_Stream_Type'Class; 537 Item : Wide_String) 538 is 539 begin 540 Wide_String_Ops.Output (Strm, Item, Block_IO); 541 end Wide_String_Output_Blk_IO; 542 543 ---------------------- 544 -- Wide_String_Read -- 545 ---------------------- 546 547 procedure Wide_String_Read 548 (Strm : access Ada.Streams.Root_Stream_Type'Class; 549 Item : out Wide_String) 550 is 551 begin 552 Wide_String_Ops.Read (Strm, Item, Byte_IO); 553 end Wide_String_Read; 554 555 ----------------------------- 556 -- Wide_String_Read_Blk_IO -- 557 ----------------------------- 558 559 procedure Wide_String_Read_Blk_IO 560 (Strm : access Ada.Streams.Root_Stream_Type'Class; 561 Item : out Wide_String) 562 is 563 begin 564 Wide_String_Ops.Read (Strm, Item, Block_IO); 565 end Wide_String_Read_Blk_IO; 566 567 ----------------------- 568 -- Wide_String_Write -- 569 ----------------------- 570 571 procedure Wide_String_Write 572 (Strm : access Ada.Streams.Root_Stream_Type'Class; 573 Item : Wide_String) 574 is 575 begin 576 Wide_String_Ops.Write (Strm, Item, Byte_IO); 577 end Wide_String_Write; 578 579 ------------------------------ 580 -- Wide_String_Write_Blk_IO -- 581 ------------------------------ 582 583 procedure Wide_String_Write_Blk_IO 584 (Strm : access Ada.Streams.Root_Stream_Type'Class; 585 Item : Wide_String) 586 is 587 begin 588 Wide_String_Ops.Write (Strm, Item, Block_IO); 589 end Wide_String_Write_Blk_IO; 590 591 ---------------------------- 592 -- Wide_Wide_String_Input -- 593 ---------------------------- 594 595 function Wide_Wide_String_Input 596 (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String 597 is 598 begin 599 return Wide_Wide_String_Ops.Input (Strm, Byte_IO); 600 end Wide_Wide_String_Input; 601 602 ----------------------------------- 603 -- Wide_Wide_String_Input_Blk_IO -- 604 ----------------------------------- 605 606 function Wide_Wide_String_Input_Blk_IO 607 (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String 608 is 609 begin 610 return Wide_Wide_String_Ops.Input (Strm, Block_IO); 611 end Wide_Wide_String_Input_Blk_IO; 612 613 ----------------------------- 614 -- Wide_Wide_String_Output -- 615 ----------------------------- 616 617 procedure Wide_Wide_String_Output 618 (Strm : access Ada.Streams.Root_Stream_Type'Class; 619 Item : Wide_Wide_String) 620 is 621 begin 622 Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); 623 end Wide_Wide_String_Output; 624 625 ------------------------------------ 626 -- Wide_Wide_String_Output_Blk_IO -- 627 ------------------------------------ 628 629 procedure Wide_Wide_String_Output_Blk_IO 630 (Strm : access Ada.Streams.Root_Stream_Type'Class; 631 Item : Wide_Wide_String) 632 is 633 begin 634 Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); 635 end Wide_Wide_String_Output_Blk_IO; 636 637 --------------------------- 638 -- Wide_Wide_String_Read -- 639 --------------------------- 640 641 procedure Wide_Wide_String_Read 642 (Strm : access Ada.Streams.Root_Stream_Type'Class; 643 Item : out Wide_Wide_String) 644 is 645 begin 646 Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); 647 end Wide_Wide_String_Read; 648 649 ---------------------------------- 650 -- Wide_Wide_String_Read_Blk_IO -- 651 ---------------------------------- 652 653 procedure Wide_Wide_String_Read_Blk_IO 654 (Strm : access Ada.Streams.Root_Stream_Type'Class; 655 Item : out Wide_Wide_String) 656 is 657 begin 658 Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); 659 end Wide_Wide_String_Read_Blk_IO; 660 661 ---------------------------- 662 -- Wide_Wide_String_Write -- 663 ---------------------------- 664 665 procedure Wide_Wide_String_Write 666 (Strm : access Ada.Streams.Root_Stream_Type'Class; 667 Item : Wide_Wide_String) 668 is 669 begin 670 Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); 671 end Wide_Wide_String_Write; 672 673 ----------------------------------- 674 -- Wide_Wide_String_Write_Blk_IO -- 675 ----------------------------------- 676 677 procedure Wide_Wide_String_Write_Blk_IO 678 (Strm : access Ada.Streams.Root_Stream_Type'Class; 679 Item : Wide_Wide_String) 680 is 681 begin 682 Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); 683 end Wide_Wide_String_Write_Blk_IO; 684 685end System.Strings.Stream_Ops; 686