gcc/ada/tree_io.adb

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