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-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
  32 pragma Compiler_Unit;
  33
  34 with Ada.Streams;              use Ada.Streams;
  35 with Ada.Streams.Stream_IO;    use Ada.Streams.Stream_IO;
  36 with Ada.Unchecked_Conversion;
  37
  38 with System.Stream_Attributes; use System;
  39
  40 package 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
 685 end System.Strings.Stream_Ops;