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