gcc/ada/libgnat/g-io.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                              G N A T . I O                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1995-2017, AdaCore                     --
  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 package body GNAT.IO is
  33
  34    Current_Out : File_Type := Stdout;
  35    pragma Atomic (Current_Out);
  36    --  Current output file (modified by Set_Output)
  37
  38    ---------
  39    -- Get --
  40    ---------
  41
  42    procedure Get (X : out Integer) is
  43       function Get_Int return Integer;
  44       pragma Import (C, Get_Int, "get_int");
  45    begin
  46       X := Get_Int;
  47    end Get;
  48
  49    procedure Get (C : out Character) is
  50       function Get_Char return Character;
  51       pragma Import (C, Get_Char, "get_char");
  52    begin
  53       C := Get_Char;
  54    end Get;
  55
  56    --------------
  57    -- Get_Line --
  58    --------------
  59
  60    procedure Get_Line (Item : out String; Last : out Natural) is
  61       C : Character;
  62
  63    begin
  64       for Nstore in Item'Range loop
  65          Get (C);
  66
  67          if C = ASCII.LF then
  68             Last := Nstore - 1;
  69             return;
  70
  71          else
  72             Item (Nstore) := C;
  73          end if;
  74       end loop;
  75
  76       Last := Item'Last;
  77    end Get_Line;
  78
  79    --------------
  80    -- New_Line --
  81    --------------
  82
  83    procedure New_Line (File : File_Type; Spacing : Positive := 1) is
  84    begin
  85       for J in 1 .. Spacing loop
  86          Put (File, ASCII.LF);
  87       end loop;
  88    end New_Line;
  89
  90    procedure New_Line (Spacing : Positive := 1) is
  91    begin
  92       New_Line (Current_Out, Spacing);
  93    end New_Line;
  94
  95    ---------
  96    -- Put --
  97    ---------
  98
  99    procedure Put (X : Integer) is
 100    begin
 101       Put (Current_Out, X);
 102    end Put;
 103
 104    procedure Put (File : File_Type; X : Integer) is
 105       procedure Put_Int (X : Integer);
 106       pragma Import (C, Put_Int, "put_int");
 107
 108       procedure Put_Int_Stderr (X : Integer);
 109       pragma Import (C, Put_Int_Stderr, "put_int_stderr");
 110
 111    begin
 112       case File is
 113          when Stdout => Put_Int (X);
 114          when Stderr => Put_Int_Stderr (X);
 115       end case;
 116    end Put;
 117
 118    procedure Put (C : Character) is
 119    begin
 120       Put (Current_Out, C);
 121    end Put;
 122
 123    procedure Put (File : File_Type; C : Character) is
 124       procedure Put_Char (C : Character);
 125       pragma Import (C, Put_Char, "put_char");
 126
 127       procedure Put_Char_Stderr (C : Character);
 128       pragma Import (C, Put_Char_Stderr, "put_char_stderr");
 129
 130    begin
 131       case File is
 132          when Stdout => Put_Char (C);
 133          when Stderr => Put_Char_Stderr (C);
 134       end case;
 135    end Put;
 136
 137    procedure Put (S : String) is
 138    begin
 139       Put (Current_Out, S);
 140    end Put;
 141
 142    procedure Put (File : File_Type; S : String) is
 143    begin
 144       for J in S'Range loop
 145          Put (File, S (J));
 146       end loop;
 147    end Put;
 148
 149    --------------
 150    -- Put_Line --
 151    --------------
 152
 153    procedure Put_Line (S : String) is
 154    begin
 155       Put_Line (Current_Out, S);
 156    end Put_Line;
 157
 158    procedure Put_Line (File : File_Type; S : String) is
 159    begin
 160       Put (File, S);
 161       New_Line (File);
 162    end Put_Line;
 163
 164    ----------------
 165    -- Set_Output --
 166    ----------------
 167
 168    procedure Set_Output (File : File_Type) is
 169    begin
 170       Current_Out := File;
 171    end Set_Output;
 172
 173    ---------------------
 174    -- Standard_Output --
 175    ---------------------
 176
 177    function Standard_Output return File_Type is
 178    begin
 179       return Stdout;
 180    end Standard_Output;
 181
 182    --------------------
 183    -- Standard_Error --
 184    --------------------
 185
 186    function Standard_Error return File_Type is
 187    begin
 188       return Stderr;
 189    end Standard_Error;
 190
 191 end GNAT.IO;