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