|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- O U T P U T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2017, 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 Output is
|
|
|
33
|
|
|
34 Buffer : String (1 .. Buffer_Max + 1) := (others => '*');
|
|
|
35 for Buffer'Alignment use 4;
|
|
|
36 -- Buffer used to build output line. We do line buffering because it is
|
|
|
37 -- needed for the support of the debug-generated-code option (-gnatD). Note
|
|
|
38 -- any attempt to write more output to a line than can fit in the buffer
|
|
|
39 -- will be silently ignored. The alignment clause improves the efficiency
|
|
|
40 -- of the save/restore procedures.
|
|
|
41
|
|
|
42 Next_Col : Positive range 1 .. Buffer'Length + 1 := 1;
|
|
|
43 -- Column about to be written
|
|
|
44
|
|
|
45 Current_FD : File_Descriptor := Standout;
|
|
|
46 -- File descriptor for current output
|
|
|
47
|
|
|
48 Special_Output_Proc : Output_Proc := null;
|
|
|
49 -- Record argument to last call to Set_Special_Output. If this is
|
|
|
50 -- non-null, then we are in special output mode.
|
|
|
51
|
|
|
52 Indentation_Amount : constant Positive := 3;
|
|
|
53 -- Number of spaces to output for each indentation level
|
|
|
54
|
|
|
55 Indentation_Limit : constant Positive := 40;
|
|
|
56 -- Indentation beyond this number of spaces wraps around
|
|
|
57
|
|
|
58 pragma Assert (Indentation_Limit < Buffer_Max / 2);
|
|
|
59 -- Make sure this is substantially shorter than the line length
|
|
|
60
|
|
|
61 Cur_Indentation : Natural := 0;
|
|
|
62 -- Number of spaces to indent each line
|
|
|
63
|
|
|
64 -----------------------
|
|
|
65 -- Local_Subprograms --
|
|
|
66 -----------------------
|
|
|
67
|
|
|
68 procedure Flush_Buffer;
|
|
|
69 -- Flush buffer if non-empty and reset column counter
|
|
|
70
|
|
|
71 ---------------------------
|
|
|
72 -- Cancel_Special_Output --
|
|
|
73 ---------------------------
|
|
|
74
|
|
|
75 procedure Cancel_Special_Output is
|
|
|
76 begin
|
|
|
77 Special_Output_Proc := null;
|
|
|
78 end Cancel_Special_Output;
|
|
|
79
|
|
|
80 ------------
|
|
|
81 -- Column --
|
|
|
82 ------------
|
|
|
83
|
|
|
84 function Column return Pos is
|
|
|
85 begin
|
|
|
86 return Pos (Next_Col);
|
|
|
87 end Column;
|
|
|
88
|
|
|
89 ----------------------
|
|
|
90 -- Delete_Last_Char --
|
|
|
91 ----------------------
|
|
|
92
|
|
|
93 procedure Delete_Last_Char is
|
|
|
94 begin
|
|
|
95 if Next_Col /= 1 then
|
|
|
96 Next_Col := Next_Col - 1;
|
|
|
97 end if;
|
|
|
98 end Delete_Last_Char;
|
|
|
99
|
|
|
100 ------------------
|
|
|
101 -- Flush_Buffer --
|
|
|
102 ------------------
|
|
|
103
|
|
|
104 procedure Flush_Buffer is
|
|
|
105 Write_Error : exception;
|
|
|
106 -- Raised if Write fails
|
|
|
107
|
|
|
108 ------------------
|
|
|
109 -- Write_Buffer --
|
|
|
110 ------------------
|
|
|
111
|
|
|
112 procedure Write_Buffer (Buf : String);
|
|
|
113 -- Write out Buf, either using Special_Output_Proc, or the normal way
|
|
|
114 -- using Write. Raise Write_Error if Write fails (presumably due to disk
|
|
|
115 -- full). Write_Error is not used in the case of Special_Output_Proc.
|
|
|
116
|
|
|
117 procedure Write_Buffer (Buf : String) is
|
|
|
118 begin
|
|
|
119 -- If Special_Output_Proc has been set, then use it
|
|
|
120
|
|
|
121 if Special_Output_Proc /= null then
|
|
|
122 Special_Output_Proc.all (Buf);
|
|
|
123
|
|
|
124 -- If output is not set, then output to either standard output
|
|
|
125 -- or standard error.
|
|
|
126
|
|
|
127 elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
|
|
|
128 raise Write_Error;
|
|
|
129
|
|
|
130 end if;
|
|
|
131 end Write_Buffer;
|
|
|
132
|
|
|
133 Len : constant Natural := Next_Col - 1;
|
|
|
134
|
|
|
135 -- Start of processing for Flush_Buffer
|
|
|
136
|
|
|
137 begin
|
|
|
138 if Len /= 0 then
|
|
|
139 begin
|
|
|
140 -- If there's no indentation, or if the line is too long with
|
|
|
141 -- indentation, or if it's a blank line, just write the buffer.
|
|
|
142
|
|
|
143 if Cur_Indentation = 0
|
|
|
144 or else Cur_Indentation + Len > Buffer_Max
|
|
|
145 or else Buffer (1 .. Len) = (1 => ASCII.LF)
|
|
|
146 then
|
|
|
147 Write_Buffer (Buffer (1 .. Len));
|
|
|
148
|
|
|
149 -- Otherwise, construct a new buffer with preceding spaces, and
|
|
|
150 -- write that.
|
|
|
151
|
|
|
152 else
|
|
|
153 declare
|
|
|
154 Indented_Buffer : constant String :=
|
|
|
155 (1 .. Cur_Indentation => ' ') &
|
|
|
156 Buffer (1 .. Len);
|
|
|
157 begin
|
|
|
158 Write_Buffer (Indented_Buffer);
|
|
|
159 end;
|
|
|
160 end if;
|
|
|
161
|
|
|
162 exception
|
|
|
163 when Write_Error =>
|
|
|
164
|
|
|
165 -- If there are errors with standard error just quit. Otherwise
|
|
|
166 -- set the output to standard error before reporting a failure
|
|
|
167 -- and quitting.
|
|
|
168
|
|
|
169 if Current_FD /= Standerr then
|
|
|
170 Current_FD := Standerr;
|
|
|
171 Next_Col := 1;
|
|
|
172 Write_Line ("fatal error: disk full");
|
|
|
173 end if;
|
|
|
174
|
|
|
175 OS_Exit (2);
|
|
|
176 end;
|
|
|
177
|
|
|
178 -- Buffer is now empty
|
|
|
179
|
|
|
180 Next_Col := 1;
|
|
|
181 end if;
|
|
|
182 end Flush_Buffer;
|
|
|
183
|
|
|
184 -------------------
|
|
|
185 -- Ignore_Output --
|
|
|
186 -------------------
|
|
|
187
|
|
|
188 procedure Ignore_Output (S : String) is
|
|
|
189 begin
|
|
|
190 null;
|
|
|
191 end Ignore_Output;
|
|
|
192
|
|
|
193 ------------
|
|
|
194 -- Indent --
|
|
|
195 ------------
|
|
|
196
|
|
|
197 procedure Indent is
|
|
|
198 begin
|
|
|
199 -- The "mod" in the following assignment is to cause a wrap around in
|
|
|
200 -- the case where there is too much indentation.
|
|
|
201
|
|
|
202 Cur_Indentation :=
|
|
|
203 (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
|
|
|
204 end Indent;
|
|
|
205
|
|
|
206 ---------------
|
|
|
207 -- Last_Char --
|
|
|
208 ---------------
|
|
|
209
|
|
|
210 function Last_Char return Character is
|
|
|
211 begin
|
|
|
212 if Next_Col /= 1 then
|
|
|
213 return Buffer (Next_Col - 1);
|
|
|
214 else
|
|
|
215 return ASCII.NUL;
|
|
|
216 end if;
|
|
|
217 end Last_Char;
|
|
|
218
|
|
|
219 -------------
|
|
|
220 -- Outdent --
|
|
|
221 -------------
|
|
|
222
|
|
|
223 procedure Outdent is
|
|
|
224 begin
|
|
|
225 -- The "mod" here undoes the wrap around from Indent above
|
|
|
226
|
|
|
227 Cur_Indentation :=
|
|
|
228 (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
|
|
|
229 end Outdent;
|
|
|
230
|
|
|
231 ---------------------------
|
|
|
232 -- Restore_Output_Buffer --
|
|
|
233 ---------------------------
|
|
|
234
|
|
|
235 procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
|
|
|
236 begin
|
|
|
237 Next_Col := S.Next_Col;
|
|
|
238 Cur_Indentation := S.Cur_Indentation;
|
|
|
239 Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
|
|
|
240 end Restore_Output_Buffer;
|
|
|
241
|
|
|
242 ------------------------
|
|
|
243 -- Save_Output_Buffer --
|
|
|
244 ------------------------
|
|
|
245
|
|
|
246 function Save_Output_Buffer return Saved_Output_Buffer is
|
|
|
247 S : Saved_Output_Buffer;
|
|
|
248 begin
|
|
|
249 S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
|
|
|
250 S.Next_Col := Next_Col;
|
|
|
251 S.Cur_Indentation := Cur_Indentation;
|
|
|
252 Next_Col := 1;
|
|
|
253 Cur_Indentation := 0;
|
|
|
254 return S;
|
|
|
255 end Save_Output_Buffer;
|
|
|
256
|
|
|
257 ------------------------
|
|
|
258 -- Set_Special_Output --
|
|
|
259 ------------------------
|
|
|
260
|
|
|
261 procedure Set_Special_Output (P : Output_Proc) is
|
|
|
262 begin
|
|
|
263 Special_Output_Proc := P;
|
|
|
264 end Set_Special_Output;
|
|
|
265
|
|
|
266 ----------------
|
|
|
267 -- Set_Output --
|
|
|
268 ----------------
|
|
|
269
|
|
|
270 procedure Set_Output (FD : File_Descriptor) is
|
|
|
271 begin
|
|
|
272 if Special_Output_Proc = null then
|
|
|
273 Flush_Buffer;
|
|
|
274 end if;
|
|
|
275
|
|
|
276 Current_FD := FD;
|
|
|
277 end Set_Output;
|
|
|
278
|
|
|
279 ------------------------
|
|
|
280 -- Set_Standard_Error --
|
|
|
281 ------------------------
|
|
|
282
|
|
|
283 procedure Set_Standard_Error is
|
|
|
284 begin
|
|
|
285 Set_Output (Standerr);
|
|
|
286 end Set_Standard_Error;
|
|
|
287
|
|
|
288 -------------------------
|
|
|
289 -- Set_Standard_Output --
|
|
|
290 -------------------------
|
|
|
291
|
|
|
292 procedure Set_Standard_Output is
|
|
|
293 begin
|
|
|
294 Set_Output (Standout);
|
|
|
295 end Set_Standard_Output;
|
|
|
296
|
|
|
297 -------
|
|
|
298 -- w --
|
|
|
299 -------
|
|
|
300
|
|
|
301 procedure w (C : Character) is
|
|
|
302 begin
|
|
|
303 Write_Char (''');
|
|
|
304 Write_Char (C);
|
|
|
305 Write_Char (''');
|
|
|
306 Write_Eol;
|
|
|
307 end w;
|
|
|
308
|
|
|
309 procedure w (S : String) is
|
|
|
310 begin
|
|
|
311 Write_Str (S);
|
|
|
312 Write_Eol;
|
|
|
313 end w;
|
|
|
314
|
|
|
315 procedure w (V : Int) is
|
|
|
316 begin
|
|
|
317 Write_Int (V);
|
|
|
318 Write_Eol;
|
|
|
319 end w;
|
|
|
320
|
|
|
321 procedure w (B : Boolean) is
|
|
|
322 begin
|
|
|
323 if B then
|
|
|
324 w ("True");
|
|
|
325 else
|
|
|
326 w ("False");
|
|
|
327 end if;
|
|
|
328 end w;
|
|
|
329
|
|
|
330 procedure w (L : String; C : Character) is
|
|
|
331 begin
|
|
|
332 Write_Str (L);
|
|
|
333 Write_Char (' ');
|
|
|
334 w (C);
|
|
|
335 end w;
|
|
|
336
|
|
|
337 procedure w (L : String; S : String) is
|
|
|
338 begin
|
|
|
339 Write_Str (L);
|
|
|
340 Write_Char (' ');
|
|
|
341 w (S);
|
|
|
342 end w;
|
|
|
343
|
|
|
344 procedure w (L : String; V : Int) is
|
|
|
345 begin
|
|
|
346 Write_Str (L);
|
|
|
347 Write_Char (' ');
|
|
|
348 w (V);
|
|
|
349 end w;
|
|
|
350
|
|
|
351 procedure w (L : String; B : Boolean) is
|
|
|
352 begin
|
|
|
353 Write_Str (L);
|
|
|
354 Write_Char (' ');
|
|
|
355 w (B);
|
|
|
356 end w;
|
|
|
357
|
|
|
358 ----------------
|
|
|
359 -- Write_Char --
|
|
|
360 ----------------
|
|
|
361
|
|
|
362 procedure Write_Char (C : Character) is
|
|
|
363 begin
|
|
|
364 pragma Assert (Next_Col in Buffer'Range);
|
|
|
365 if Next_Col = Buffer'Length then
|
|
|
366 Write_Eol;
|
|
|
367 end if;
|
|
|
368
|
|
|
369 if C = ASCII.LF then
|
|
|
370 Write_Eol;
|
|
|
371 else
|
|
|
372 Buffer (Next_Col) := C;
|
|
|
373 Next_Col := Next_Col + 1;
|
|
|
374 end if;
|
|
|
375 end Write_Char;
|
|
|
376
|
|
|
377 ---------------
|
|
|
378 -- Write_Eol --
|
|
|
379 ---------------
|
|
|
380
|
|
|
381 procedure Write_Eol is
|
|
|
382 begin
|
|
|
383 -- Remove any trailing spaces
|
|
|
384
|
|
|
385 while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
|
|
|
386 Next_Col := Next_Col - 1;
|
|
|
387 end loop;
|
|
|
388
|
|
|
389 Buffer (Next_Col) := ASCII.LF;
|
|
|
390 Next_Col := Next_Col + 1;
|
|
|
391 Flush_Buffer;
|
|
|
392 end Write_Eol;
|
|
|
393
|
|
|
394 ---------------------------
|
|
|
395 -- Write_Eol_Keep_Blanks --
|
|
|
396 ---------------------------
|
|
|
397
|
|
|
398 procedure Write_Eol_Keep_Blanks is
|
|
|
399 begin
|
|
|
400 Buffer (Next_Col) := ASCII.LF;
|
|
|
401 Next_Col := Next_Col + 1;
|
|
|
402 Flush_Buffer;
|
|
|
403 end Write_Eol_Keep_Blanks;
|
|
|
404
|
|
|
405 ----------------------
|
|
|
406 -- Write_Erase_Char --
|
|
|
407 ----------------------
|
|
|
408
|
|
|
409 procedure Write_Erase_Char (C : Character) is
|
|
|
410 begin
|
|
|
411 if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
|
|
|
412 Next_Col := Next_Col - 1;
|
|
|
413 end if;
|
|
|
414 end Write_Erase_Char;
|
|
|
415
|
|
|
416 ---------------
|
|
|
417 -- Write_Int --
|
|
|
418 ---------------
|
|
|
419
|
|
|
420 procedure Write_Int (Val : Int) is
|
|
|
421 -- Type Int has one extra negative number (i.e. two's complement), so we
|
|
|
422 -- work with negative numbers here. Otherwise, negating Int'First will
|
|
|
423 -- overflow.
|
|
|
424
|
|
|
425 subtype Nonpositive is Int range Int'First .. 0;
|
|
|
426 procedure Write_Abs (Val : Nonpositive);
|
|
|
427 -- Write out the absolute value of Val
|
|
|
428
|
|
|
429 procedure Write_Abs (Val : Nonpositive) is
|
|
|
430 begin
|
|
|
431 if Val < -9 then
|
|
|
432 Write_Abs (Val / 10); -- Recursively write higher digits
|
|
|
433 end if;
|
|
|
434
|
|
|
435 Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0')));
|
|
|
436 end Write_Abs;
|
|
|
437
|
|
|
438 begin
|
|
|
439 if Val < 0 then
|
|
|
440 Write_Char ('-');
|
|
|
441 Write_Abs (Val);
|
|
|
442 else
|
|
|
443 Write_Abs (-Val);
|
|
|
444 end if;
|
|
|
445 end Write_Int;
|
|
|
446
|
|
|
447 ----------------
|
|
|
448 -- Write_Line --
|
|
|
449 ----------------
|
|
|
450
|
|
|
451 procedure Write_Line (S : String) is
|
|
|
452 begin
|
|
|
453 Write_Str (S);
|
|
|
454 Write_Eol;
|
|
|
455 end Write_Line;
|
|
|
456
|
|
|
457 ------------------
|
|
|
458 -- Write_Spaces --
|
|
|
459 ------------------
|
|
|
460
|
|
|
461 procedure Write_Spaces (N : Nat) is
|
|
|
462 begin
|
|
|
463 for J in 1 .. N loop
|
|
|
464 Write_Char (' ');
|
|
|
465 end loop;
|
|
|
466 end Write_Spaces;
|
|
|
467
|
|
|
468 ---------------
|
|
|
469 -- Write_Str --
|
|
|
470 ---------------
|
|
|
471
|
|
|
472 procedure Write_Str (S : String) is
|
|
|
473 begin
|
|
|
474 for J in S'Range loop
|
|
|
475 Write_Char (S (J));
|
|
|
476 end loop;
|
|
|
477 end Write_Str;
|
|
|
478
|
|
|
479 end Output;
|
