gcc/ada/libgnat/a-tiboio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --               A D A . T E X T _ I O . B O U N D E D _ I O                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2017, 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 with Ada.Text_IO; use Ada.Text_IO;
  33 with Ada.Unchecked_Deallocation;
  34
  35 package body Ada.Text_IO.Bounded_IO is
  36
  37    type String_Access is access all String;
  38
  39    procedure Free (SA : in out String_Access);
  40    --  Perform an unchecked deallocation of a non-null string
  41
  42    ----------
  43    -- Free --
  44    ----------
  45
  46    procedure Free (SA : in out String_Access) is
  47       Null_String : constant String := "";
  48
  49       procedure Deallocate is
  50         new Ada.Unchecked_Deallocation (String, String_Access);
  51
  52    begin
  53       --  Do not try to free statically allocated null string
  54
  55       if SA.all /= Null_String then
  56          Deallocate (SA);
  57       end if;
  58    end Free;
  59
  60    --------------
  61    -- Get_Line --
  62    --------------
  63
  64    function Get_Line return Bounded.Bounded_String is
  65    begin
  66       return Bounded.To_Bounded_String (Get_Line);
  67    end Get_Line;
  68
  69    --------------
  70    -- Get_Line --
  71    --------------
  72
  73    function Get_Line
  74      (File : File_Type) return Bounded.Bounded_String
  75    is
  76    begin
  77       return Bounded.To_Bounded_String (Get_Line (File));
  78    end Get_Line;
  79
  80    --------------
  81    -- Get_Line --
  82    --------------
  83
  84    procedure Get_Line
  85      (Item : out Bounded.Bounded_String)
  86    is
  87       Buffer : String (1 .. 1000);
  88       Last   : Natural;
  89       Str1   : String_Access;
  90       Str2   : String_Access;
  91
  92    begin
  93       Get_Line (Buffer, Last);
  94       Str1 := new String'(Buffer (1 .. Last));
  95
  96       while Last = Buffer'Last loop
  97          Get_Line (Buffer, Last);
  98          Str2 := new String'(Str1.all & Buffer (1 .. Last));
  99          Free (Str1);
 100          Str1 := Str2;
 101       end loop;
 102
 103       Item := Bounded.To_Bounded_String (Str1.all);
 104    end Get_Line;
 105
 106    --------------
 107    -- Get_Line --
 108    --------------
 109
 110    procedure Get_Line
 111      (File : File_Type;
 112       Item : out Bounded.Bounded_String)
 113    is
 114       Buffer : String (1 .. 1000);
 115       Last   : Natural;
 116       Str1   : String_Access;
 117       Str2   : String_Access;
 118
 119    begin
 120       Get_Line (File, Buffer, Last);
 121       Str1 := new String'(Buffer (1 .. Last));
 122
 123       while Last = Buffer'Last loop
 124          Get_Line (File, Buffer, Last);
 125          Str2 := new String'(Str1.all & Buffer (1 .. Last));
 126          Free (Str1);
 127          Str1 := Str2;
 128       end loop;
 129
 130       Item := Bounded.To_Bounded_String (Str1.all);
 131    end Get_Line;
 132
 133    ---------
 134    -- Put --
 135    ---------
 136
 137    procedure Put
 138      (Item : Bounded.Bounded_String)
 139    is
 140    begin
 141       Put (Bounded.To_String (Item));
 142    end Put;
 143
 144    ---------
 145    -- Put --
 146    ---------
 147
 148    procedure Put
 149      (File : File_Type;
 150       Item : Bounded.Bounded_String)
 151    is
 152    begin
 153       Put (File, Bounded.To_String (Item));
 154    end Put;
 155
 156    --------------
 157    -- Put_Line --
 158    --------------
 159
 160    procedure Put_Line
 161      (Item : Bounded.Bounded_String)
 162    is
 163    begin
 164       Put_Line (Bounded.To_String (Item));
 165    end Put_Line;
 166
 167    --------------
 168    -- Put_Line --
 169    --------------
 170
 171    procedure Put_Line
 172      (File : File_Type;
 173       Item : Bounded.Bounded_String)
 174    is
 175    begin
 176       Put_Line (File, Bounded.To_String (Item));
 177    end Put_Line;
 178
 179 end Ada.Text_IO.Bounded_IO;