Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/output.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;