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-2019, 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 32package 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 479end Output; 480