source: trunk/src/gcc/gcc/ada/output.adb@ 2

Last change on this file since 2 was 2, checked in by bird, 22 years ago

Initial revision
  • Property cvs2svn:cvs-rev set to 1.1
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 5.9 KB
Line 
1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- O U T P U T --
6-- --
7-- B o d y --
8-- --
9-- $Revision: 1.1.16.1 $
10-- --
11-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
12-- --
13-- GNAT is free software; you can redistribute it and/or modify it under --
14-- terms of the GNU General Public License as published by the Free Soft- --
15-- ware Foundation; either version 2, or (at your option) any later ver- --
16-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19-- for more details. You should have received a copy of the GNU General --
20-- Public License distributed with GNAT; see file COPYING. If not, write --
21-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22-- MA 02111-1307, USA. --
23-- --
24-- As a special exception, if other files instantiate generics from this --
25-- unit, or you link this unit with other files to produce an executable, --
26-- this unit does not by itself cause the resulting executable to be --
27-- covered by the GNU General Public License. This exception does not --
28-- however invalidate any other reasons why the executable file might be --
29-- covered by the GNU Public License. --
30-- --
31-- GNAT was originally developed by the GNAT team at New York University. --
32-- Extensive contributions were provided by Ada Core Technologies Inc. --
33-- --
34------------------------------------------------------------------------------
35
36with GNAT.OS_Lib; use GNAT.OS_Lib;
37
38package body Output is
39
40 Current_FD : File_Descriptor := Standout;
41 -- File descriptor for current output
42
43 -----------------------
44 -- Local_Subprograms --
45 -----------------------
46
47 procedure Flush_Buffer;
48 -- Flush buffer if non-empty and reset column counter
49
50 ------------------
51 -- Flush_Buffer --
52 ------------------
53
54 procedure Flush_Buffer is
55 Len : constant Natural := Natural (Column - 1);
56
57 begin
58 if Len /= 0 then
59 if Len /= Write (Current_FD, Buffer'Address, Len) then
60 Set_Standard_Error;
61 Write_Line ("fatal error: disk full");
62 OS_Exit (2);
63 end if;
64
65 Column := 1;
66 end if;
67 end Flush_Buffer;
68
69 ------------------------
70 -- Set_Standard_Error --
71 ------------------------
72
73 procedure Set_Standard_Error is
74 begin
75 Flush_Buffer;
76 Current_FD := Standerr;
77 Column := 1;
78 end Set_Standard_Error;
79
80 -------------------------
81 -- Set_Standard_Output --
82 -------------------------
83
84 procedure Set_Standard_Output is
85 begin
86 Flush_Buffer;
87 Current_FD := Standout;
88 Column := 1;
89 end Set_Standard_Output;
90
91 -------
92 -- w --
93 -------
94
95 procedure w (C : Character) is
96 begin
97 Write_Char (''');
98 Write_Char (C);
99 Write_Char (''');
100 Write_Eol;
101 end w;
102
103 procedure w (S : String) is
104 begin
105 Write_Str (S);
106 Write_Eol;
107 end w;
108
109 procedure w (V : Int) is
110 begin
111 Write_Int (V);
112 Write_Eol;
113 end w;
114
115 procedure w (B : Boolean) is
116 begin
117 if B then
118 w ("True");
119 else
120 w ("False");
121 end if;
122 end w;
123
124 procedure w (L : String; C : Character) is
125 begin
126 Write_Str (L);
127 Write_Char (' ');
128 w (C);
129 end w;
130
131 procedure w (L : String; S : String) is
132 begin
133 Write_Str (L);
134 Write_Char (' ');
135 w (S);
136 end w;
137
138 procedure w (L : String; V : Int) is
139 begin
140 Write_Str (L);
141 Write_Char (' ');
142 w (V);
143 end w;
144
145 procedure w (L : String; B : Boolean) is
146 begin
147 Write_Str (L);
148 Write_Char (' ');
149 w (B);
150 end w;
151
152 ----------------
153 -- Write_Char --
154 ----------------
155
156 procedure Write_Char (C : Character) is
157 begin
158 if Column < Buffer'Length then
159 Buffer (Natural (Column)) := C;
160 Column := Column + 1;
161 end if;
162 end Write_Char;
163
164 ---------------
165 -- Write_Eol --
166 ---------------
167
168 procedure Write_Eol is
169 begin
170 Buffer (Natural (Column)) := ASCII.LF;
171 Column := Column + 1;
172 Flush_Buffer;
173 end Write_Eol;
174
175 ---------------
176 -- Write_Int --
177 ---------------
178
179 procedure Write_Int (Val : Int) is
180 begin
181 if Val < 0 then
182 Write_Char ('-');
183 Write_Int (-Val);
184
185 else
186 if Val > 9 then
187 Write_Int (Val / 10);
188 end if;
189
190 Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
191 end if;
192 end Write_Int;
193
194 ----------------
195 -- Write_Line --
196 ----------------
197
198 procedure Write_Line (S : String) is
199 begin
200 Write_Str (S);
201 Write_Eol;
202 end Write_Line;
203
204 ---------------
205 -- Write_Str --
206 ---------------
207
208 procedure Write_Str (S : String) is
209 begin
210 for J in S'Range loop
211 Write_Char (S (J));
212 end loop;
213 end Write_Str;
214
215end Output;
Note: See TracBrowser for help on using the repository browser.