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-2009, 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 =>
  63             Put_Int (X);
  64          when Stderr =>
  65             Put_Int_Err (X);
  66       end case;
  67    end Put;
  68
  69    procedure Put (C : Character) is
  70       procedure Put_Char (C : Character);
  71       pragma Import (C, Put_Char, "put_char");
  72
  73       procedure Put_Char_Stderr (C : Character);
  74       pragma Import (C, Put_Char_Stderr, "put_char_stderr");
  75
  76    begin
  77       case Current_Out is
  78          when Stdout =>
  79             Put_Char (C);
  80          when Stderr =>
  81             Put_Char_Stderr (C);
  82       end case;
  83    end Put;
  84
  85    procedure Put (S : String) is
  86    begin
  87       for J in S'Range loop
  88          Put (S (J));
  89       end loop;
  90    end Put;
  91
  92    --------------
  93    -- Put_Line --
  94    --------------
  95
  96    procedure Put_Line (S : String) is
  97    begin
  98       Put (S);
  99       New_Line;
 100    end Put_Line;
 101
 102    ---------------------
 103    -- Standard_Output --
 104    ---------------------
 105
 106    function Standard_Output return File_Type is
 107    begin
 108       return Stdout;
 109    end Standard_Output;
 110
 111    --------------------
 112    -- Standard_Error --
 113    --------------------
 114
 115    function Standard_Error return File_Type is
 116    begin
 117       return Stderr;
 118    end Standard_Error;
 119
 120    ----------------
 121    -- Set_Output --
 122    ----------------
 123
 124    procedure Set_Output (File : File_Type) is
 125    begin
 126       Current_Out := File;
 127    end Set_Output;
 128
 129 end System.IO;