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