File : 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 -- --
19 -- --
20 -- --
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;