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