1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Debug; use Debug;
35 with Output; use Output;
36 with Unchecked_Conversion;
38 package body Tree_IO is
39 Debug_Flag_Tree : Boolean := False;
40 -- Debug flag for debug output from tree read/write
42 -------------------------------------------
43 -- Compression Scheme Used for Tree File --
44 -------------------------------------------
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:
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
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.
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
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
70 Max_Count : constant := 63;
71 -- Maximum data length for one compression sequence
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.
78 type Int_Bytes is array (1 .. 4) of Byte;
79 for Int_Bytes'Size use 32;
81 function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
82 function To_Int is new Unchecked_Conversion (Int_Bytes, Int);
84 ----------------------
85 -- Global Variables --
86 ----------------------
88 Tree_FD : File_Descriptor;
89 -- File descriptor for tree
91 Buflen : constant Int := 8_192;
92 -- Length of buffer for read and write file data
94 Buf : array (Pos range 1 .. Buflen) of Byte;
95 -- Read/write file data buffer
98 -- Number of bytes read/written from/to buffer
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.
105 -----------------------
106 -- Local Subprograms --
107 -----------------------
109 procedure Read_Buffer;
110 -- Reads data into buffer, setting Bufe appropriately
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
116 procedure Write_Buffer;
117 -- Writes out current buffer contents
119 procedure Write_Byte (B : Byte);
120 pragma Inline (Write_Byte);
121 -- Write one byte to output buffer, checking for buffer-full condition
127 procedure Read_Buffer is
129 Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
132 raise Tree_Format_Error;
142 function Read_Byte return Byte is
156 procedure Tree_Read_Bool (B : out Boolean) is
158 B := Boolean'Val (Read_Byte);
160 if Debug_Flag_Tree then
175 procedure Tree_Read_Char (C : out Character) is
177 C := Character'Val (Read_Byte);
179 if Debug_Flag_Tree then
180 Write_Str ("==> transmitting Character = ");
190 procedure Tree_Read_Data (Addr : Address; Length : Int) is
192 type S is array (Pos) of Byte;
193 -- This is a big array, for which we have to suppress the warning
195 type SP is access all S;
197 function To_SP is new Unchecked_Conversion (Address, SP);
199 Data : constant SP := To_SP (Addr);
200 -- Data buffer to be read as an indexable array of bytes
203 -- Pointer to next byte of data buffer to be read into
210 if Debug_Flag_Tree then
211 Write_Str ("==> transmitting ");
213 Write_Str (" data bytes");
217 -- Verify data length
222 Write_Str ("==> transmitting, expected ");
224 Write_Str (" bytes, found length = ");
227 raise Tree_Format_Error;
232 while OP <= Length loop
234 -- Get compression control character
237 C := B and 2#00_111111#;
238 B := B and 2#11_000000#;
242 if B = C_Noncomp then
243 if Debug_Flag_Tree then
244 Write_Str ("==> uncompressed: ");
246 Write_Str (", starting at ");
252 Data (OP) := Read_Byte;
258 elsif B = C_Zeros then
259 if Debug_Flag_Tree then
260 Write_Str ("==> zeroes: ");
262 Write_Str (", starting at ");
274 elsif B = C_Spaces then
275 if Debug_Flag_Tree then
276 Write_Str ("==> spaces: ");
278 Write_Str (", starting at ");
284 Data (OP) := Character'Pos (' ');
288 -- Specified repeated character
293 if Debug_Flag_Tree then
294 Write_Str ("==> other char: ");
299 Write_Str (", starting at ");
311 -- At end of loop, data item must be exactly filled
313 if OP /= Length + 1 then
314 raise Tree_Format_Error;
319 --------------------------
320 -- Tree_Read_Initialize --
321 --------------------------
323 procedure Tree_Read_Initialize (Desc : File_Descriptor) is
328 Debug_Flag_Tree := Debug_Flag_5;
329 end Tree_Read_Initialize;
335 procedure Tree_Read_Int (N : out Int) is
340 N_Bytes (J) := Read_Byte;
343 N := To_Int (N_Bytes);
345 if Debug_Flag_Tree then
346 Write_Str ("==> transmitting Int = ");
356 procedure Tree_Read_Str (S : out String_Ptr) is
361 S := new String (1 .. Natural (N));
362 Tree_Read_Data (S.all (1)'Address, N);
365 -------------------------
366 -- Tree_Read_Terminate --
367 -------------------------
369 procedure Tree_Read_Terminate is
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.
376 pragma Warnings (Off, B);
382 when Tree_Format_Error => return;
385 raise Tree_Format_Error;
386 end Tree_Read_Terminate;
388 ---------------------
389 -- Tree_Write_Bool --
390 ---------------------
392 procedure Tree_Write_Bool (B : Boolean) is
394 if Debug_Flag_Tree then
395 Write_Str ("==> transmitting Boolean = ");
406 Write_Byte (Boolean'Pos (B));
409 ---------------------
410 -- Tree_Write_Char --
411 ---------------------
413 procedure Tree_Write_Char (C : Character) is
415 if Debug_Flag_Tree then
416 Write_Str ("==> transmitting Character = ");
421 Write_Byte (Character'Pos (C));
424 ---------------------
425 -- Tree_Write_Data --
426 ---------------------
428 procedure Tree_Write_Data (Addr : Address; Length : Int) is
430 type S is array (Pos) of Byte;
431 -- This is a big array, for which we have to suppress the warning
433 type SP is access all S;
435 function To_SP is new Unchecked_Conversion (Address, SP);
437 Data : constant SP := To_SP (Addr);
438 -- Pointer to data to be written, converted to array type
441 -- Input buffer pointer, next byte to be processed
443 NC : Nat range 0 .. Max_Count := 0;
444 -- Number of bytes of non-compressible sequence
448 procedure Write_Non_Compressed_Sequence;
449 -- Output currently collected sequence of non-compressible data
451 procedure Write_Non_Compressed_Sequence is
454 Write_Byte (C_Noncomp + Byte (NC));
456 if Debug_Flag_Tree then
457 Write_Str ("==> uncompressed: ");
459 Write_Str (", starting at ");
464 for J in reverse 1 .. NC loop
465 Write_Byte (Data (IP - J));
470 end Write_Non_Compressed_Sequence;
472 -- Start of processing for Tree_Write_Data
475 if Debug_Flag_Tree then
476 Write_Str ("==> transmitting ");
478 Write_Str (" data bytes");
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
485 Tree_Write_Int (Length);
488 -- IP is index of next input character
489 -- NC is number of non-compressible bytes saved up
492 -- If input is completely processed, then we are all done
495 Write_Non_Compressed_Sequence;
499 -- Test for compressible sequence, must be at least three identical
500 -- bytes in a row to be worthwhile compressing.
503 and then Data (IP) = Data (IP + 1)
504 and then Data (IP) = Data (IP + 2)
506 Write_Non_Compressed_Sequence;
508 -- Count length of new compression sequence
514 and then Data (IP) = Data (IP - 1)
515 and then C < Max_Count
521 -- Output compression sequence
523 if Data (IP - 1) = 0 then
524 if Debug_Flag_Tree then
525 Write_Str ("==> zeroes: ");
527 Write_Str (", starting at ");
528 Write_Int (IP - Int (C));
532 Write_Byte (C_Zeros + C);
534 elsif Data (IP - 1) = Character'Pos (' ') then
535 if Debug_Flag_Tree then
536 Write_Str ("==> spaces: ");
538 Write_Str (", starting at ");
539 Write_Int (IP - Int (C));
543 Write_Byte (C_Spaces + C);
546 if Debug_Flag_Tree then
547 Write_Str ("==> other char: ");
550 Write_Int (Int (Data (IP - 1)));
552 Write_Str (", starting at ");
553 Write_Int (IP - Int (C));
557 Write_Byte (C_Repeat + C);
558 Write_Byte (Data (IP - 1));
561 -- No compression possible here
564 -- Output non-compressed sequence if at maximum length
566 if NC = Max_Count then
567 Write_Non_Compressed_Sequence;
577 ---------------------------
578 -- Tree_Write_Initialize --
579 ---------------------------
581 procedure Tree_Write_Initialize (Desc : File_Descriptor) is
586 Debug_Flag_Tree := Debug_Flag_5;
587 end Tree_Write_Initialize;
593 procedure Tree_Write_Int (N : Int) is
594 N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
597 if Debug_Flag_Tree then
598 Write_Str ("==> transmitting Int = ");
604 Write_Byte (N_Bytes (J));
612 procedure Tree_Write_Str (S : String_Ptr) is
614 Tree_Write_Int (S'Length);
615 Tree_Write_Data (S (1)'Address, S'Length);
618 --------------------------
619 -- Tree_Write_Terminate --
620 --------------------------
622 procedure Tree_Write_Terminate is
627 end Tree_Write_Terminate;
633 procedure Write_Buffer is
635 if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
640 Write_Str ("fatal error: disk full");
649 procedure Write_Byte (B : Byte) is
654 if Bufn = Buflen then