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 --                            $Revision: 1.13 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Debug;  use Debug;
  37 with Output; use Output;
  38 with Unchecked_Conversion;
  39
  40 package body Tree_IO is
  41    Debug_Flag_Tree : Boolean := False;
  42    --  Debug flag for debug output from tree read/write
  43
  44    -------------------------------------------
  45    -- Compression Scheme Used for Tree File --
  46    -------------------------------------------
  47
  48    --  We don't just write the data directly, but instead do a mild form
  49    --  of compression, since we expect lots of compressible zeroes and
  50    --  blanks. The compression scheme is as follows:
  51
  52    --    00nnnnnn followed by nnnnnn bytes (non compressed data)
  53    --    01nnnnnn indicates nnnnnn binary zero bytes
  54    --    10nnnnnn indicates nnnnnn ASCII space bytes
  55    --    11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb
  56
  57    --  Since we expect many zeroes in trees, and many spaces in sources,
  58    --  this compression should be reasonably efficient. We can put in
  59    --  something better later on.
  60
  61    --  Note that this compression applies to the Write_Tree_Data and
  62    --  Read_Tree_Data calls, not to the calls to read and write single
  63    --  scalar values, which are written in memory format without any
  64    --  compression.
  65
  66    C_Noncomp : constant := 2#00_000000#;
  67    C_Zeros   : constant := 2#01_000000#;
  68    C_Spaces  : constant := 2#10_000000#;
  69    C_Repeat  : constant := 2#11_000000#;
  70    --  Codes for compression sequences
  71
  72    Max_Count : constant := 63;
  73    --  Maximum data length for one compression sequence
  74
  75    Max_Comp : constant := Max_Count + 1;
  76    --  Maximum length of one compression sequence
  77
  78    --  The above compression scheme applies only to data written with the
  79    --  Tree_Write routine and read with Tree_Read. Data written using the
  80    --  Tree_Write_Char or Tree_Write_Int routines and read using the
  81    --  corresponding input routines is not compressed.
  82
  83    type Int_Bytes is array (1 .. 4) of Byte;
  84    for Int_Bytes'Size use 32;
  85
  86    function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
  87    function To_Int       is new Unchecked_Conversion (Int_Bytes, Int);
  88
  89    ----------------------
  90    -- Global Variables --
  91    ----------------------
  92
  93    Tree_FD : File_Descriptor;
  94    --  File descriptor for tree
  95
  96    Buflen : constant Int := 8_192;
  97    --  Length of buffer for read and write file data
  98
  99    Buf : array (Pos range 1 .. Buflen) of Byte;
 100    --  Read/write file data buffer
 101
 102    Bufn : Nat;
 103    --  Number of bytes read/written from/to buffer
 104
 105    Buft : Nat;
 106    --  Total number of bytes in input buffer containing valid data. Used only
 107    --  for input operations. There is data left to be processed in the buffer
 108    --  if Buft > Bufn. A value of zero for Buft means that the buffer is empty.
 109
 110    -----------------------
 111    -- Local Subprograms --
 112    -----------------------
 113
 114    procedure Read_Buffer;
 115    --  Reads data into buffer, setting Bufe appropriately
 116
 117    function Read_Byte return Byte;
 118    pragma Inline (Read_Byte);
 119    --  Returns next byte from input file, raises Tree_Format_Error if none left
 120
 121    procedure Write_Buffer;
 122    --  Writes out current buffer contents
 123
 124    procedure Write_Byte (B : Byte);
 125    pragma Inline (Write_Byte);
 126    --  Write one byte to output buffer, checking for buffer-full condition
 127
 128    -----------------
 129    -- Read_Buffer --
 130    -----------------
 131
 132    procedure Read_Buffer is
 133    begin
 134       Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
 135
 136       if Buft = 0 then
 137          raise Tree_Format_Error;
 138       else
 139          Bufn := 0;
 140       end if;
 141    end Read_Buffer;
 142
 143    ---------------
 144    -- Read_Byte --
 145    ---------------
 146
 147    function Read_Byte return Byte is
 148    begin
 149       if Bufn = Buft then
 150          Read_Buffer;
 151       end if;
 152
 153       Bufn := Bufn + 1;
 154       return Buf (Bufn);
 155    end Read_Byte;
 156
 157    --------------------
 158    -- Tree_Read_Bool --
 159    --------------------
 160
 161    procedure Tree_Read_Bool (B : out Boolean) is
 162    begin
 163       B := Boolean'Val (Read_Byte);
 164
 165       if Debug_Flag_Tree then
 166          if B then
 167             Write_Str ("True");
 168          else
 169             Write_Str ("False");
 170          end if;
 171
 172          Write_Eol;
 173       end if;
 174    end Tree_Read_Bool;
 175
 176    --------------------
 177    -- Tree_Read_Char --
 178    --------------------
 179
 180    procedure Tree_Read_Char (C : out Character) is
 181    begin
 182       C := Character'Val (Read_Byte);
 183
 184       if Debug_Flag_Tree then
 185          Write_Str ("==> transmitting Character = ");
 186          Write_Char (C);
 187          Write_Eol;
 188       end if;
 189    end Tree_Read_Char;
 190
 191    --------------------
 192    -- Tree_Read_Data --
 193    --------------------
 194
 195    procedure Tree_Read_Data (Addr : Address; Length : Int) is
 196
 197       type S is array (Pos) of Byte;
 198       --  This is a big array, for which we have to suppress the warning
 199
 200       type SP is access all S;
 201
 202       function To_SP is new Unchecked_Conversion (Address, SP);
 203
 204       Data : constant SP := To_SP (Addr);
 205       --  Data buffer to be read as an indexable array of bytes
 206
 207       OP : Pos := 1;
 208       --  Pointer to next byte of data buffer to be read into
 209
 210       B : Byte;
 211       C : Byte;
 212       L : Int;
 213
 214    begin
 215       if Debug_Flag_Tree then
 216          Write_Str ("==> transmitting ");
 217          Write_Int (Length);
 218          Write_Str (" data bytes");
 219          Write_Eol;
 220       end if;
 221
 222       --  Verify data length
 223
 224       Tree_Read_Int (L);
 225
 226       if L /= Length then
 227          Write_Str ("==> transmitting, expected ");
 228          Write_Int (Length);
 229          Write_Str (" bytes, found length = ");
 230          Write_Int (L);
 231          Write_Eol;
 232          raise Tree_Format_Error;
 233       end if;
 234
 235       --  Loop to read data
 236
 237       while OP <= Length loop
 238
 239          --  Get compression control character
 240
 241          B := Read_Byte;
 242          C := B and 2#00_111111#;
 243          B := B and 2#11_000000#;
 244
 245          --  Non-repeat case
 246
 247          if B = C_Noncomp then
 248             if Debug_Flag_Tree then
 249                Write_Str ("==>    uncompressed:  ");
 250                Write_Int (Int (C));
 251                Write_Str (", starting at ");
 252                Write_Int (OP);
 253                Write_Eol;
 254             end if;
 255
 256             for J in 1 .. C loop
 257                Data (OP) := Read_Byte;
 258                OP := OP + 1;
 259             end loop;
 260
 261          --  Repeated zeroes
 262
 263          elsif B = C_Zeros then
 264             if Debug_Flag_Tree then
 265                Write_Str ("==>    zeroes:        ");
 266                Write_Int (Int (C));
 267                Write_Str (", starting at ");
 268                Write_Int (OP);
 269                Write_Eol;
 270             end if;
 271
 272             for J in 1 .. C loop
 273                Data (OP) := 0;
 274                OP := OP + 1;
 275             end loop;
 276
 277          --  Repeated spaces
 278
 279          elsif B = C_Spaces then
 280             if Debug_Flag_Tree then
 281                Write_Str ("==>    spaces:        ");
 282                Write_Int (Int (C));
 283                Write_Str (", starting at ");
 284                Write_Int (OP);
 285                Write_Eol;
 286             end if;
 287
 288             for J in 1 .. C loop
 289                Data (OP) := Character'Pos (' ');
 290                OP := OP + 1;
 291             end loop;
 292
 293          --  Specified repeated character
 294
 295          else -- B = C_Repeat
 296             B := Read_Byte;
 297
 298             if Debug_Flag_Tree then
 299                Write_Str ("==>    other char:    ");
 300                Write_Int (Int (C));
 301                Write_Str (" (");
 302                Write_Int (Int (B));
 303                Write_Char (')');
 304                Write_Str (", starting at ");
 305                Write_Int (OP);
 306                Write_Eol;
 307             end if;
 308
 309             for J in 1 .. C loop
 310                Data (OP) := B;
 311                OP := OP + 1;
 312             end loop;
 313          end if;
 314       end loop;
 315
 316       --  At end of loop, data item must be exactly filled
 317
 318       if OP /= Length + 1 then
 319          raise Tree_Format_Error;
 320       end if;
 321
 322    end Tree_Read_Data;
 323
 324    --------------------------
 325    -- Tree_Read_Initialize --
 326    --------------------------
 327
 328    procedure Tree_Read_Initialize (Desc : File_Descriptor) is
 329    begin
 330       Buft := 0;
 331       Bufn := 0;
 332       Tree_FD := Desc;
 333       Debug_Flag_Tree := Debug_Flag_5;
 334    end Tree_Read_Initialize;
 335
 336    -------------------
 337    -- Tree_Read_Int --
 338    -------------------
 339
 340    procedure Tree_Read_Int (N : out Int) is
 341       N_Bytes : Int_Bytes;
 342
 343    begin
 344       for J in 1 .. 4 loop
 345          N_Bytes (J) := Read_Byte;
 346       end loop;
 347
 348       N := To_Int (N_Bytes);
 349
 350       if Debug_Flag_Tree then
 351          Write_Str ("==> transmitting Int = ");
 352          Write_Int (N);
 353          Write_Eol;
 354       end if;
 355    end Tree_Read_Int;
 356
 357    -------------------
 358    -- Tree_Read_Str --
 359    -------------------
 360
 361    procedure Tree_Read_Str (S : out String_Ptr) is
 362       N : Nat;
 363
 364    begin
 365       Tree_Read_Int (N);
 366       S := new String (1 .. Natural (N));
 367       Tree_Read_Data (S.all (1)'Address, N);
 368    end Tree_Read_Str;
 369
 370    -------------------------
 371    -- Tree_Read_Terminate --
 372    -------------------------
 373
 374    procedure Tree_Read_Terminate is
 375    begin
 376       --  Must be at end of input buffer, so we should get Tree_Format_Error
 377       --  if we try to read one more byte, if not, we have a format error.
 378
 379       declare
 380          B : Byte;
 381       begin
 382          B := Read_Byte;
 383       exception
 384          when Tree_Format_Error => return;
 385       end;
 386
 387       raise Tree_Format_Error;
 388    end Tree_Read_Terminate;
 389
 390    ---------------------
 391    -- Tree_Write_Bool --
 392    ---------------------
 393
 394    procedure Tree_Write_Bool (B : Boolean) is
 395    begin
 396       if Debug_Flag_Tree then
 397          Write_Str ("==> transmitting Boolean = ");
 398
 399          if B then
 400             Write_Str ("True");
 401          else
 402             Write_Str ("False");
 403          end if;
 404
 405          Write_Eol;
 406       end if;
 407
 408       Write_Byte (Boolean'Pos (B));
 409    end Tree_Write_Bool;
 410
 411    ---------------------
 412    -- Tree_Write_Char --
 413    ---------------------
 414
 415    procedure Tree_Write_Char (C : Character) is
 416    begin
 417       if Debug_Flag_Tree then
 418          Write_Str ("==> transmitting Character = ");
 419          Write_Char (C);
 420          Write_Eol;
 421       end if;
 422
 423       Write_Byte (Character'Pos (C));
 424    end Tree_Write_Char;
 425
 426    ---------------------
 427    -- Tree_Write_Data --
 428    ---------------------
 429
 430    procedure Tree_Write_Data (Addr : Address; Length : Int) is
 431
 432       type S is array (Pos) of Byte;
 433       --  This is a big array, for which we have to suppress the warning
 434
 435       type SP is access all S;
 436
 437       function To_SP is new Unchecked_Conversion (Address, SP);
 438
 439       Data : constant SP := To_SP (Addr);
 440       --  Pointer to data to be written, converted to array type
 441
 442       IP : Pos := 1;
 443       --  Input buffer pointer, next byte to be processed
 444
 445       NC : Nat range 0 .. Max_Count := 0;
 446       --  Number of bytes of non-compressible sequence
 447
 448       C  : Byte;
 449
 450       procedure Write_Non_Compressed_Sequence;
 451       --  Output currently collected sequence of non-compressible data
 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
 661 end Tree_IO;