1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- T R E E _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009 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 32with Debug; use Debug; 33with Output; use Output; 34with Unchecked_Conversion; 35 36package body Tree_IO is 37 Debug_Flag_Tree : Boolean := False; 38 -- Debug flag for debug output from tree read/write 39 40 ------------------------------------------- 41 -- Compression Scheme Used for Tree File -- 42 ------------------------------------------- 43 44 -- We don't just write the data directly, but instead do a mild form 45 -- of compression, since we expect lots of compressible zeroes and 46 -- blanks. The compression scheme is as follows: 47 48 -- 00nnnnnn followed by nnnnnn bytes (non compressed data) 49 -- 01nnnnnn indicates nnnnnn binary zero bytes 50 -- 10nnnnnn indicates nnnnnn ASCII space bytes 51 -- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb 52 53 -- Since we expect many zeroes in trees, and many spaces in sources, 54 -- this compression should be reasonably efficient. We can put in 55 -- something better later on. 56 57 -- Note that this compression applies to the Write_Tree_Data and 58 -- Read_Tree_Data calls, not to the calls to read and write single 59 -- scalar values, which are written in memory format without any 60 -- compression. 61 62 C_Noncomp : constant := 2#00_000000#; 63 C_Zeros : constant := 2#01_000000#; 64 C_Spaces : constant := 2#10_000000#; 65 C_Repeat : constant := 2#11_000000#; 66 -- Codes for compression sequences 67 68 Max_Count : constant := 63; 69 -- Maximum data length for one compression sequence 70 71 -- The above compression scheme applies only to data written with the 72 -- Tree_Write routine and read with Tree_Read. Data written using the 73 -- Tree_Write_Char or Tree_Write_Int routines and read using the 74 -- corresponding input routines is not compressed. 75 76 type Int_Bytes is array (1 .. 4) of Byte; 77 for Int_Bytes'Size use 32; 78 79 function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes); 80 function To_Int is new Unchecked_Conversion (Int_Bytes, Int); 81 82 ---------------------- 83 -- Global Variables -- 84 ---------------------- 85 86 Tree_FD : File_Descriptor; 87 -- File descriptor for tree 88 89 Buflen : constant Int := 8_192; 90 -- Length of buffer for read and write file data 91 92 Buf : array (Pos range 1 .. Buflen) of Byte; 93 -- Read/write file data buffer 94 95 Bufn : Nat; 96 -- Number of bytes read/written from/to buffer 97 98 Buft : Nat; 99 -- Total number of bytes in input buffer containing valid data. Used only 100 -- for input operations. There is data left to be processed in the buffer 101 -- if Buft > Bufn. A value of zero for Buft means that the buffer is empty. 102 103 ----------------------- 104 -- Local Subprograms -- 105 ----------------------- 106 107 procedure Read_Buffer; 108 -- Reads data into buffer, setting Bufn appropriately 109 110 function Read_Byte return Byte; 111 pragma Inline (Read_Byte); 112 -- Returns next byte from input file, raises Tree_Format_Error if none left 113 114 procedure Write_Buffer; 115 -- Writes out current buffer contents 116 117 procedure Write_Byte (B : Byte); 118 pragma Inline (Write_Byte); 119 -- Write one byte to output buffer, checking for buffer-full condition 120 121 ----------------- 122 -- Read_Buffer -- 123 ----------------- 124 125 procedure Read_Buffer is 126 begin 127 Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen))); 128 129 if Buft = 0 then 130 raise Tree_Format_Error; 131 else 132 Bufn := 0; 133 end if; 134 end Read_Buffer; 135 136 --------------- 137 -- Read_Byte -- 138 --------------- 139 140 function Read_Byte return Byte is 141 begin 142 if Bufn = Buft then 143 Read_Buffer; 144 end if; 145 146 Bufn := Bufn + 1; 147 return Buf (Bufn); 148 end Read_Byte; 149 150 -------------------- 151 -- Tree_Read_Bool -- 152 -------------------- 153 154 procedure Tree_Read_Bool (B : out Boolean) is 155 begin 156 B := Boolean'Val (Read_Byte); 157 158 if Debug_Flag_Tree then 159 if B then 160 Write_Str ("True"); 161 else 162 Write_Str ("False"); 163 end if; 164 165 Write_Eol; 166 end if; 167 end Tree_Read_Bool; 168 169 -------------------- 170 -- Tree_Read_Char -- 171 -------------------- 172 173 procedure Tree_Read_Char (C : out Character) is 174 begin 175 C := Character'Val (Read_Byte); 176 177 if Debug_Flag_Tree then 178 Write_Str ("==> transmitting Character = "); 179 Write_Char (C); 180 Write_Eol; 181 end if; 182 end Tree_Read_Char; 183 184 -------------------- 185 -- Tree_Read_Data -- 186 -------------------- 187 188 procedure Tree_Read_Data (Addr : Address; Length : Int) is 189 190 type S is array (Pos) of Byte; 191 -- This is a big array, for which we have to suppress the warning 192 193 type SP is access all S; 194 195 function To_SP is new Unchecked_Conversion (Address, SP); 196 197 Data : constant SP := To_SP (Addr); 198 -- Data buffer to be read as an indexable array of bytes 199 200 OP : Pos := 1; 201 -- Pointer to next byte of data buffer to be read into 202 203 B : Byte; 204 C : Byte; 205 L : Int; 206 207 begin 208 if Debug_Flag_Tree then 209 Write_Str ("==> transmitting "); 210 Write_Int (Length); 211 Write_Str (" data bytes"); 212 Write_Eol; 213 end if; 214 215 -- Verify data length 216 217 Tree_Read_Int (L); 218 219 if L /= Length then 220 Write_Str ("==> transmitting, expected "); 221 Write_Int (Length); 222 Write_Str (" bytes, found length = "); 223 Write_Int (L); 224 Write_Eol; 225 raise Tree_Format_Error; 226 end if; 227 228 -- Loop to read data 229 230 while OP <= Length loop 231 232 -- Get compression control character 233 234 B := Read_Byte; 235 C := B and 2#00_111111#; 236 B := B and 2#11_000000#; 237 238 -- Non-repeat case 239 240 if B = C_Noncomp then 241 if Debug_Flag_Tree then 242 Write_Str ("==> uncompressed: "); 243 Write_Int (Int (C)); 244 Write_Str (", starting at "); 245 Write_Int (OP); 246 Write_Eol; 247 end if; 248 249 for J in 1 .. C loop 250 Data (OP) := Read_Byte; 251 OP := OP + 1; 252 end loop; 253 254 -- Repeated zeroes 255 256 elsif B = C_Zeros then 257 if Debug_Flag_Tree then 258 Write_Str ("==> zeroes: "); 259 Write_Int (Int (C)); 260 Write_Str (", starting at "); 261 Write_Int (OP); 262 Write_Eol; 263 end if; 264 265 for J in 1 .. C loop 266 Data (OP) := 0; 267 OP := OP + 1; 268 end loop; 269 270 -- Repeated spaces 271 272 elsif B = C_Spaces then 273 if Debug_Flag_Tree then 274 Write_Str ("==> spaces: "); 275 Write_Int (Int (C)); 276 Write_Str (", starting at "); 277 Write_Int (OP); 278 Write_Eol; 279 end if; 280 281 for J in 1 .. C loop 282 Data (OP) := Character'Pos (' '); 283 OP := OP + 1; 284 end loop; 285 286 -- Specified repeated character 287 288 else -- B = C_Repeat 289 B := Read_Byte; 290 291 if Debug_Flag_Tree then 292 Write_Str ("==> other char: "); 293 Write_Int (Int (C)); 294 Write_Str (" ("); 295 Write_Int (Int (B)); 296 Write_Char (')'); 297 Write_Str (", starting at "); 298 Write_Int (OP); 299 Write_Eol; 300 end if; 301 302 for J in 1 .. C loop 303 Data (OP) := B; 304 OP := OP + 1; 305 end loop; 306 end if; 307 end loop; 308 309 -- At end of loop, data item must be exactly filled 310 311 if OP /= Length + 1 then 312 raise Tree_Format_Error; 313 end if; 314 315 end Tree_Read_Data; 316 317 -------------------------- 318 -- Tree_Read_Initialize -- 319 -------------------------- 320 321 procedure Tree_Read_Initialize (Desc : File_Descriptor) is 322 begin 323 Buft := 0; 324 Bufn := 0; 325 Tree_FD := Desc; 326 Debug_Flag_Tree := Debug_Flag_5; 327 end Tree_Read_Initialize; 328 329 ------------------- 330 -- Tree_Read_Int -- 331 ------------------- 332 333 procedure Tree_Read_Int (N : out Int) is 334 N_Bytes : Int_Bytes; 335 336 begin 337 for J in 1 .. 4 loop 338 N_Bytes (J) := Read_Byte; 339 end loop; 340 341 N := To_Int (N_Bytes); 342 343 if Debug_Flag_Tree then 344 Write_Str ("==> transmitting Int = "); 345 Write_Int (N); 346 Write_Eol; 347 end if; 348 end Tree_Read_Int; 349 350 ------------------- 351 -- Tree_Read_Str -- 352 ------------------- 353 354 procedure Tree_Read_Str (S : out String_Ptr) is 355 N : Nat; 356 357 begin 358 Tree_Read_Int (N); 359 S := new String (1 .. Natural (N)); 360 Tree_Read_Data (S.all (1)'Address, N); 361 end Tree_Read_Str; 362 363 ------------------------- 364 -- Tree_Read_Terminate -- 365 ------------------------- 366 367 procedure Tree_Read_Terminate is 368 begin 369 -- Must be at end of input buffer, so we should get Tree_Format_Error 370 -- if we try to read one more byte, if not, we have a format error. 371 372 declare 373 B : Byte; 374 pragma Warnings (Off, B); 375 376 begin 377 B := Read_Byte; 378 379 exception 380 when Tree_Format_Error => return; 381 end; 382 383 raise Tree_Format_Error; 384 end Tree_Read_Terminate; 385 386 --------------------- 387 -- Tree_Write_Bool -- 388 --------------------- 389 390 procedure Tree_Write_Bool (B : Boolean) is 391 begin 392 if Debug_Flag_Tree then 393 Write_Str ("==> transmitting Boolean = "); 394 395 if B then 396 Write_Str ("True"); 397 else 398 Write_Str ("False"); 399 end if; 400 401 Write_Eol; 402 end if; 403 404 Write_Byte (Boolean'Pos (B)); 405 end Tree_Write_Bool; 406 407 --------------------- 408 -- Tree_Write_Char -- 409 --------------------- 410 411 procedure Tree_Write_Char (C : Character) is 412 begin 413 if Debug_Flag_Tree then 414 Write_Str ("==> transmitting Character = "); 415 Write_Char (C); 416 Write_Eol; 417 end if; 418 419 Write_Byte (Character'Pos (C)); 420 end Tree_Write_Char; 421 422 --------------------- 423 -- Tree_Write_Data -- 424 --------------------- 425 426 procedure Tree_Write_Data (Addr : Address; Length : Int) is 427 428 type S is array (Pos) of Byte; 429 -- This is a big array, for which we have to suppress the warning 430 431 type SP is access all S; 432 433 function To_SP is new Unchecked_Conversion (Address, SP); 434 435 Data : constant SP := To_SP (Addr); 436 -- Pointer to data to be written, converted to array type 437 438 IP : Pos := 1; 439 -- Input buffer pointer, next byte to be processed 440 441 NC : Nat range 0 .. Max_Count := 0; 442 -- Number of bytes of non-compressible sequence 443 444 C : Byte; 445 446 procedure Write_Non_Compressed_Sequence; 447 -- Output currently collected sequence of non-compressible data 448 449 ----------------------------------- 450 -- Write_Non_Compressed_Sequence -- 451 ----------------------------------- 452 453 procedure Write_Non_Compressed_Sequence is 454 begin 455 if NC > 0 then 456 Write_Byte (C_Noncomp + Byte (NC)); 457 458 if Debug_Flag_Tree then 459 Write_Str ("==> uncompressed: "); 460 Write_Int (NC); 461 Write_Str (", starting at "); 462 Write_Int (IP - NC); 463 Write_Eol; 464 end if; 465 466 for J in reverse 1 .. NC loop 467 Write_Byte (Data (IP - J)); 468 end loop; 469 470 NC := 0; 471 end if; 472 end Write_Non_Compressed_Sequence; 473 474 -- Start of processing for Tree_Write_Data 475 476 begin 477 if Debug_Flag_Tree then 478 Write_Str ("==> transmitting "); 479 Write_Int (Length); 480 Write_Str (" data bytes"); 481 Write_Eol; 482 end if; 483 484 -- We write the count at the start, so that we can check it on 485 -- the corresponding read to make sure that reads and writes match 486 487 Tree_Write_Int (Length); 488 489 -- Conversion loop 490 -- IP is index of next input character 491 -- NC is number of non-compressible bytes saved up 492 493 loop 494 -- If input is completely processed, then we are all done 495 496 if IP > Length then 497 Write_Non_Compressed_Sequence; 498 return; 499 end if; 500 501 -- Test for compressible sequence, must be at least three identical 502 -- bytes in a row to be worthwhile compressing. 503 504 if IP + 2 <= Length 505 and then Data (IP) = Data (IP + 1) 506 and then Data (IP) = Data (IP + 2) 507 then 508 Write_Non_Compressed_Sequence; 509 510 -- Count length of new compression sequence 511 512 C := 3; 513 IP := IP + 3; 514 515 while IP < Length 516 and then Data (IP) = Data (IP - 1) 517 and then C < Max_Count 518 loop 519 C := C + 1; 520 IP := IP + 1; 521 end loop; 522 523 -- Output compression sequence 524 525 if Data (IP - 1) = 0 then 526 if Debug_Flag_Tree then 527 Write_Str ("==> zeroes: "); 528 Write_Int (Int (C)); 529 Write_Str (", starting at "); 530 Write_Int (IP - Int (C)); 531 Write_Eol; 532 end if; 533 534 Write_Byte (C_Zeros + C); 535 536 elsif Data (IP - 1) = Character'Pos (' ') then 537 if Debug_Flag_Tree then 538 Write_Str ("==> spaces: "); 539 Write_Int (Int (C)); 540 Write_Str (", starting at "); 541 Write_Int (IP - Int (C)); 542 Write_Eol; 543 end if; 544 545 Write_Byte (C_Spaces + C); 546 547 else 548 if Debug_Flag_Tree then 549 Write_Str ("==> other char: "); 550 Write_Int (Int (C)); 551 Write_Str (" ("); 552 Write_Int (Int (Data (IP - 1))); 553 Write_Char (')'); 554 Write_Str (", starting at "); 555 Write_Int (IP - Int (C)); 556 Write_Eol; 557 end if; 558 559 Write_Byte (C_Repeat + C); 560 Write_Byte (Data (IP - 1)); 561 end if; 562 563 -- No compression possible here 564 565 else 566 -- Output non-compressed sequence if at maximum length 567 568 if NC = Max_Count then 569 Write_Non_Compressed_Sequence; 570 end if; 571 572 NC := NC + 1; 573 IP := IP + 1; 574 end if; 575 end loop; 576 577 end Tree_Write_Data; 578 579 --------------------------- 580 -- Tree_Write_Initialize -- 581 --------------------------- 582 583 procedure Tree_Write_Initialize (Desc : File_Descriptor) is 584 begin 585 Bufn := 0; 586 Tree_FD := Desc; 587 Set_Standard_Error; 588 Debug_Flag_Tree := Debug_Flag_5; 589 end Tree_Write_Initialize; 590 591 -------------------- 592 -- Tree_Write_Int -- 593 -------------------- 594 595 procedure Tree_Write_Int (N : Int) is 596 N_Bytes : constant Int_Bytes := To_Int_Bytes (N); 597 598 begin 599 if Debug_Flag_Tree then 600 Write_Str ("==> transmitting Int = "); 601 Write_Int (N); 602 Write_Eol; 603 end if; 604 605 for J in 1 .. 4 loop 606 Write_Byte (N_Bytes (J)); 607 end loop; 608 end Tree_Write_Int; 609 610 -------------------- 611 -- Tree_Write_Str -- 612 -------------------- 613 614 procedure Tree_Write_Str (S : String_Ptr) is 615 begin 616 Tree_Write_Int (S'Length); 617 Tree_Write_Data (S (1)'Address, S'Length); 618 end Tree_Write_Str; 619 620 -------------------------- 621 -- Tree_Write_Terminate -- 622 -------------------------- 623 624 procedure Tree_Write_Terminate is 625 begin 626 if Bufn > 0 then 627 Write_Buffer; 628 end if; 629 end Tree_Write_Terminate; 630 631 ------------------ 632 -- Write_Buffer -- 633 ------------------ 634 635 procedure Write_Buffer is 636 begin 637 if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then 638 Bufn := 0; 639 640 else 641 Set_Standard_Error; 642 Write_Str ("fatal error: disk full"); 643 OS_Exit (2); 644 end if; 645 end Write_Buffer; 646 647 ---------------- 648 -- Write_Byte -- 649 ---------------- 650 651 procedure Write_Byte (B : Byte) is 652 begin 653 Bufn := Bufn + 1; 654 Buf (Bufn) := B; 655 656 if Bufn = Buflen then 657 Write_Buffer; 658 end if; 659 end Write_Byte; 660 661end Tree_IO; 662