gcc/ada/s-ststop.adb

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