]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- O U T P U T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
38cbfe40 RK |
9 | -- Copyright (C) 1992-2001, 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 2, 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. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- As a special exception, if other files instantiate generics from this -- | |
23 | -- unit, or you link this unit with other files to produce an executable, -- | |
24 | -- this unit does not by itself cause the resulting executable to be -- | |
25 | -- covered by the GNU General Public License. This exception does not -- | |
26 | -- however invalidate any other reasons why the executable file might be -- | |
27 | -- covered by the GNU Public License. -- | |
28 | -- -- | |
29 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
31 | -- -- |
32 | ------------------------------------------------------------------------------ | |
33 | ||
34 | with GNAT.OS_Lib; use GNAT.OS_Lib; | |
35 | ||
36 | package body Output is | |
37 | ||
38 | Current_FD : File_Descriptor := Standout; | |
39 | -- File descriptor for current output | |
40 | ||
07fc65c4 GB |
41 | Special_Output_Proc : Output_Proc := null; |
42 | -- Record argument to last call to Set_Special_Output. If this is | |
43 | -- non-null, then we are in special output mode. | |
44 | ||
45 | ------------------------- | |
46 | -- Line Buffer Control -- | |
47 | ------------------------- | |
48 | ||
49 | -- Note: the following buffer and column position are maintained by | |
50 | -- the subprograms defined in this package, and are not normally | |
51 | -- directly modified or accessed by a client. However, a client is | |
52 | -- permitted to modify these values, using the knowledge that only | |
53 | -- Write_Eol actually generates any output. | |
54 | ||
55 | Buffer_Max : constant := 8192; | |
56 | Buffer : String (1 .. Buffer_Max + 1); | |
57 | -- Buffer used to build output line. We do line buffering because it | |
58 | -- is needed for the support of the debug-generated-code option (-gnatD). | |
59 | -- Historically it was first added because on VMS, line buffering is | |
60 | -- needed with certain file formats. So in any case line buffering must | |
61 | -- be retained for this purpose, even if other reasons disappear. Note | |
62 | -- any attempt to write more output to a line than can fit in the buffer | |
63 | -- will be silently ignored. | |
64 | ||
65 | Next_Column : Pos range 1 .. Buffer'Length + 1 := 1; | |
66 | -- Column about to be written. | |
67 | ||
38cbfe40 RK |
68 | ----------------------- |
69 | -- Local_Subprograms -- | |
70 | ----------------------- | |
71 | ||
72 | procedure Flush_Buffer; | |
73 | -- Flush buffer if non-empty and reset column counter | |
74 | ||
07fc65c4 GB |
75 | --------------------------- |
76 | -- Cancel_Special_Output -- | |
77 | --------------------------- | |
78 | ||
79 | procedure Cancel_Special_Output is | |
80 | begin | |
81 | Special_Output_Proc := null; | |
82 | end Cancel_Special_Output; | |
83 | ||
38cbfe40 RK |
84 | ------------------ |
85 | -- Flush_Buffer -- | |
86 | ------------------ | |
87 | ||
88 | procedure Flush_Buffer is | |
07fc65c4 | 89 | Len : constant Natural := Natural (Next_Column - 1); |
38cbfe40 RK |
90 | |
91 | begin | |
92 | if Len /= 0 then | |
07fc65c4 GB |
93 | |
94 | -- If Special_Output_Proc has been set, then use it | |
95 | ||
96 | if Special_Output_Proc /= null then | |
97 | Special_Output_Proc.all (Buffer (1 .. Len)); | |
98 | ||
99 | -- If output is not set, then output to either standard output | |
100 | -- or standard error. | |
101 | ||
102 | elsif Len /= Write (Current_FD, Buffer'Address, Len) then | |
103 | ||
104 | -- If there are errors with standard error, just quit | |
105 | ||
106 | if Current_FD = Standerr then | |
107 | OS_Exit (2); | |
108 | ||
109 | -- Otherwise, set the output to standard error before | |
110 | -- reporting a failure and quitting. | |
111 | ||
112 | else | |
113 | Current_FD := Standerr; | |
114 | Next_Column := 1; | |
115 | Write_Line ("fatal error: disk full"); | |
116 | OS_Exit (2); | |
117 | end if; | |
38cbfe40 RK |
118 | end if; |
119 | ||
07fc65c4 GB |
120 | -- Buffer is now empty |
121 | ||
122 | Next_Column := 1; | |
38cbfe40 RK |
123 | end if; |
124 | end Flush_Buffer; | |
125 | ||
07fc65c4 GB |
126 | ------------ |
127 | -- Column -- | |
128 | ------------ | |
129 | ||
130 | function Column return Nat is | |
131 | begin | |
132 | return Next_Column; | |
133 | end Column; | |
134 | ||
135 | ------------------------ | |
136 | -- Set_Special_Output -- | |
137 | ------------------------ | |
138 | ||
139 | procedure Set_Special_Output (P : Output_Proc) is | |
140 | begin | |
141 | Special_Output_Proc := P; | |
142 | end Set_Special_Output; | |
143 | ||
38cbfe40 RK |
144 | ------------------------ |
145 | -- Set_Standard_Error -- | |
146 | ------------------------ | |
147 | ||
148 | procedure Set_Standard_Error is | |
149 | begin | |
07fc65c4 GB |
150 | if Special_Output_Proc = null then |
151 | Flush_Buffer; | |
152 | Next_Column := 1; | |
153 | end if; | |
154 | ||
38cbfe40 | 155 | Current_FD := Standerr; |
38cbfe40 RK |
156 | end Set_Standard_Error; |
157 | ||
158 | ------------------------- | |
159 | -- Set_Standard_Output -- | |
160 | ------------------------- | |
161 | ||
162 | procedure Set_Standard_Output is | |
163 | begin | |
07fc65c4 GB |
164 | if Special_Output_Proc = null then |
165 | Flush_Buffer; | |
166 | Next_Column := 1; | |
167 | end if; | |
168 | ||
38cbfe40 | 169 | Current_FD := Standout; |
38cbfe40 RK |
170 | end Set_Standard_Output; |
171 | ||
172 | ------- | |
173 | -- w -- | |
174 | ------- | |
175 | ||
176 | procedure w (C : Character) is | |
177 | begin | |
178 | Write_Char ('''); | |
179 | Write_Char (C); | |
180 | Write_Char ('''); | |
181 | Write_Eol; | |
182 | end w; | |
183 | ||
184 | procedure w (S : String) is | |
185 | begin | |
186 | Write_Str (S); | |
187 | Write_Eol; | |
188 | end w; | |
189 | ||
190 | procedure w (V : Int) is | |
191 | begin | |
192 | Write_Int (V); | |
193 | Write_Eol; | |
194 | end w; | |
195 | ||
196 | procedure w (B : Boolean) is | |
197 | begin | |
198 | if B then | |
199 | w ("True"); | |
200 | else | |
201 | w ("False"); | |
202 | end if; | |
203 | end w; | |
204 | ||
205 | procedure w (L : String; C : Character) is | |
206 | begin | |
207 | Write_Str (L); | |
208 | Write_Char (' '); | |
209 | w (C); | |
210 | end w; | |
211 | ||
212 | procedure w (L : String; S : String) is | |
213 | begin | |
214 | Write_Str (L); | |
215 | Write_Char (' '); | |
216 | w (S); | |
217 | end w; | |
218 | ||
219 | procedure w (L : String; V : Int) is | |
220 | begin | |
221 | Write_Str (L); | |
222 | Write_Char (' '); | |
223 | w (V); | |
224 | end w; | |
225 | ||
226 | procedure w (L : String; B : Boolean) is | |
227 | begin | |
228 | Write_Str (L); | |
229 | Write_Char (' '); | |
230 | w (B); | |
231 | end w; | |
232 | ||
233 | ---------------- | |
234 | -- Write_Char -- | |
235 | ---------------- | |
236 | ||
237 | procedure Write_Char (C : Character) is | |
238 | begin | |
07fc65c4 GB |
239 | if Next_Column < Buffer'Length then |
240 | Buffer (Natural (Next_Column)) := C; | |
241 | Next_Column := Next_Column + 1; | |
38cbfe40 RK |
242 | end if; |
243 | end Write_Char; | |
244 | ||
245 | --------------- | |
246 | -- Write_Eol -- | |
247 | --------------- | |
248 | ||
249 | procedure Write_Eol is | |
250 | begin | |
07fc65c4 GB |
251 | Buffer (Natural (Next_Column)) := ASCII.LF; |
252 | Next_Column := Next_Column + 1; | |
38cbfe40 RK |
253 | Flush_Buffer; |
254 | end Write_Eol; | |
255 | ||
256 | --------------- | |
257 | -- Write_Int -- | |
258 | --------------- | |
259 | ||
260 | procedure Write_Int (Val : Int) is | |
261 | begin | |
262 | if Val < 0 then | |
263 | Write_Char ('-'); | |
264 | Write_Int (-Val); | |
265 | ||
266 | else | |
267 | if Val > 9 then | |
268 | Write_Int (Val / 10); | |
269 | end if; | |
270 | ||
271 | Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); | |
272 | end if; | |
273 | end Write_Int; | |
274 | ||
275 | ---------------- | |
276 | -- Write_Line -- | |
277 | ---------------- | |
278 | ||
279 | procedure Write_Line (S : String) is | |
280 | begin | |
281 | Write_Str (S); | |
282 | Write_Eol; | |
283 | end Write_Line; | |
284 | ||
285 | --------------- | |
286 | -- Write_Str -- | |
287 | --------------- | |
288 | ||
289 | procedure Write_Str (S : String) is | |
290 | begin | |
291 | for J in S'Range loop | |
292 | Write_Char (S (J)); | |
293 | end loop; | |
294 | end Write_Str; | |
295 | ||
296 | end Output; |