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 --          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
  34 with Debug;  use Debug;
  35 with Output; use Output;
  36 with Unchecked_Conversion;
  37
  38 package 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
 659 end Tree_IO;