gcc/ada/s-io.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                            S Y S T E M . I O                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, 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 package body System.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    -- New_Line --
  40    --------------
  41
  42    procedure New_Line (Spacing : Positive := 1) is
  43    begin
  44       for J in 1 .. Spacing loop
  45          Put (ASCII.LF);
  46       end loop;
  47    end New_Line;
  48
  49    ---------
  50    -- Put --
  51    ---------
  52
  53    procedure Put (X : Integer) is
  54       procedure Put_Int (X : Integer);
  55       pragma Import (C, Put_Int, "put_int");
  56
  57       procedure Put_Int_Err (X : Integer);
  58       pragma Import (C, Put_Int_Err, "put_int_stderr");
  59
  60    begin
  61       case Current_Out is
  62          when Stdout => Put_Int (X);
  63          when Stderr => Put_Int_Err (X);
  64       end case;
  65    end Put;
  66
  67    procedure Put (C : Character) is
  68       procedure Put_Char (C : Character);
  69       pragma Import (C, Put_Char, "put_char");
  70
  71       procedure Put_Char_Stderr (C : Character);
  72       pragma Import (C, Put_Char_Stderr, "put_char_stderr");
  73
  74    begin
  75       case Current_Out is
  76          when Stdout => Put_Char (C);
  77          when Stderr => Put_Char_Stderr (C);
  78       end case;
  79    end Put;
  80
  81    procedure Put (S : String) is
  82    begin
  83       for J in S'Range loop
  84          Put (S (J));
  85       end loop;
  86    end Put;
  87
  88    --------------
  89    -- Put_Line --
  90    --------------
  91
  92    procedure Put_Line (S : String) is
  93    begin
  94       Put (S);
  95       New_Line;
  96    end Put_Line;
  97
  98    ---------------------
  99    -- Standard_Output --
 100    ---------------------
 101
 102    function Standard_Output return File_Type is
 103    begin
 104       return Stdout;
 105    end Standard_Output;
 106
 107    --------------------
 108    -- Standard_Error --
 109    --------------------
 110
 111    function Standard_Error return File_Type is
 112    begin
 113       return Stderr;
 114    end Standard_Error;
 115
 116    ----------------
 117    -- Set_Output --
 118    ----------------
 119
 120    procedure Set_Output (File : File_Type) is
 121    begin
 122       Current_Out := File;
 123    end Set_Output;
 124
 125 end System.IO;