1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
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. --
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. --
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). --
33 ------------------------------------------------------------------------------
35 with Debug
; use Debug
;
36 with Output
; use Output
;
37 with Unchecked_Conversion
;
39 package body Tree_IO
is
40 Debug_Flag_Tree
: Boolean := False;
41 -- Debug flag for debug output from tree read/write
43 -------------------------------------------
44 -- Compression Scheme Used for Tree File --
45 -------------------------------------------
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:
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
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.
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
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
71 Max_Count
: constant := 63;
72 -- Maximum data length for one compression sequence
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.
79 type Int_Bytes
is array (1 .. 4) of Byte
;
80 for Int_Bytes
'Size use 32;
82 function To_Int_Bytes
is new Unchecked_Conversion
(Int
, Int_Bytes
);
83 function To_Int
is new Unchecked_Conversion
(Int_Bytes
, Int
);
85 ----------------------
86 -- Global Variables --
87 ----------------------
89 Tree_FD
: File_Descriptor
;
90 -- File descriptor for tree
92 Buflen
: constant Int
:= 8_192
;
93 -- Length of buffer for read and write file data
95 Buf
: array (Pos
range 1 .. Buflen
) of Byte
;
96 -- Read/write file data buffer
99 -- Number of bytes read/written from/to buffer
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.
106 -----------------------
107 -- Local Subprograms --
108 -----------------------
110 procedure Read_Buffer
;
111 -- Reads data into buffer, setting Bufe appropriately
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
117 procedure Write_Buffer
;
118 -- Writes out current buffer contents
120 procedure Write_Byte
(B
: Byte
);
121 pragma Inline
(Write_Byte
);
122 -- Write one byte to output buffer, checking for buffer-full condition
128 procedure Read_Buffer
is
130 Buft
:= Int
(Read
(Tree_FD
, Buf
(1)'Address, Integer (Buflen
)));
133 raise Tree_Format_Error
;
143 function Read_Byte
return Byte
is
157 procedure Tree_Read_Bool
(B
: out Boolean) is
159 B
:= Boolean'Val (Read_Byte
);
161 if Debug_Flag_Tree
then
176 procedure Tree_Read_Char
(C
: out Character) is
178 C
:= Character'Val (Read_Byte
);
180 if Debug_Flag_Tree
then
181 Write_Str
("==> transmitting Character = ");
191 procedure Tree_Read_Data
(Addr
: Address
; Length
: Int
) is
193 type S
is array (Pos
) of Byte
;
194 -- This is a big array, for which we have to suppress the warning
196 type SP
is access all S
;
198 function To_SP
is new Unchecked_Conversion
(Address
, SP
);
200 Data
: constant SP
:= To_SP
(Addr
);
201 -- Data buffer to be read as an indexable array of bytes
204 -- Pointer to next byte of data buffer to be read into
211 if Debug_Flag_Tree
then
212 Write_Str
("==> transmitting ");
214 Write_Str
(" data bytes");
218 -- Verify data length
223 Write_Str
("==> transmitting, expected ");
225 Write_Str
(" bytes, found length = ");
228 raise Tree_Format_Error
;
233 while OP
<= Length
loop
235 -- Get compression control character
238 C
:= B
and 2#
00_111111#
;
239 B
:= B
and 2#
11_000000#
;
243 if B
= C_Noncomp
then
244 if Debug_Flag_Tree
then
245 Write_Str
("==> uncompressed: ");
247 Write_Str
(", starting at ");
253 Data
(OP
) := Read_Byte
;
259 elsif B
= C_Zeros
then
260 if Debug_Flag_Tree
then
261 Write_Str
("==> zeroes: ");
263 Write_Str
(", starting at ");
275 elsif B
= C_Spaces
then
276 if Debug_Flag_Tree
then
277 Write_Str
("==> spaces: ");
279 Write_Str
(", starting at ");
285 Data
(OP
) := Character'Pos (' ');
289 -- Specified repeated character
294 if Debug_Flag_Tree
then
295 Write_Str
("==> other char: ");
300 Write_Str
(", starting at ");
312 -- At end of loop, data item must be exactly filled
314 if OP
/= Length
+ 1 then
315 raise Tree_Format_Error
;
320 --------------------------
321 -- Tree_Read_Initialize --
322 --------------------------
324 procedure Tree_Read_Initialize
(Desc
: File_Descriptor
) is
329 Debug_Flag_Tree
:= Debug_Flag_5
;
330 end Tree_Read_Initialize
;
336 procedure Tree_Read_Int
(N
: out Int
) is
341 N_Bytes
(J
) := Read_Byte
;
344 N
:= To_Int
(N_Bytes
);
346 if Debug_Flag_Tree
then
347 Write_Str
("==> transmitting Int = ");
357 procedure Tree_Read_Str
(S
: out String_Ptr
) is
362 S
:= new String (1 .. Natural (N
));
363 Tree_Read_Data
(S
.all (1)'Address, N
);
366 -------------------------
367 -- Tree_Read_Terminate --
368 -------------------------
370 procedure Tree_Read_Terminate
is
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.
380 when Tree_Format_Error
=> return;
383 raise Tree_Format_Error
;
384 end Tree_Read_Terminate
;
386 ---------------------
387 -- Tree_Write_Bool --
388 ---------------------
390 procedure Tree_Write_Bool
(B
: Boolean) is
392 if Debug_Flag_Tree
then
393 Write_Str
("==> transmitting Boolean = ");
404 Write_Byte
(Boolean'Pos (B
));
407 ---------------------
408 -- Tree_Write_Char --
409 ---------------------
411 procedure Tree_Write_Char
(C
: Character) is
413 if Debug_Flag_Tree
then
414 Write_Str
("==> transmitting Character = ");
419 Write_Byte
(Character'Pos (C
));
422 ---------------------
423 -- Tree_Write_Data --
424 ---------------------
426 procedure Tree_Write_Data
(Addr
: Address
; Length
: Int
) is
428 type S
is array (Pos
) of Byte
;
429 -- This is a big array, for which we have to suppress the warning
431 type SP
is access all S
;
433 function To_SP
is new Unchecked_Conversion
(Address
, SP
);
435 Data
: constant SP
:= To_SP
(Addr
);
436 -- Pointer to data to be written, converted to array type
439 -- Input buffer pointer, next byte to be processed
441 NC
: Nat
range 0 .. Max_Count
:= 0;
442 -- Number of bytes of non-compressible sequence
446 procedure Write_Non_Compressed_Sequence
;
447 -- Output currently collected sequence of non-compressible data
449 procedure Write_Non_Compressed_Sequence
is
452 Write_Byte
(C_Noncomp
+ Byte
(NC
));
454 if Debug_Flag_Tree
then
455 Write_Str
("==> uncompressed: ");
457 Write_Str
(", starting at ");
462 for J
in reverse 1 .. NC
loop
463 Write_Byte
(Data
(IP
- J
));
468 end Write_Non_Compressed_Sequence
;
470 -- Start of processing for Tree_Write_Data
473 if Debug_Flag_Tree
then
474 Write_Str
("==> transmitting ");
476 Write_Str
(" data bytes");
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
483 Tree_Write_Int
(Length
);
486 -- IP is index of next input character
487 -- NC is number of non-compressible bytes saved up
490 -- If input is completely processed, then we are all done
493 Write_Non_Compressed_Sequence
;
497 -- Test for compressible sequence, must be at least three identical
498 -- bytes in a row to be worthwhile compressing.
501 and then Data
(IP
) = Data
(IP
+ 1)
502 and then Data
(IP
) = Data
(IP
+ 2)
504 Write_Non_Compressed_Sequence
;
506 -- Count length of new compression sequence
512 and then Data
(IP
) = Data
(IP
- 1)
513 and then C
< Max_Count
519 -- Output compression sequence
521 if Data
(IP
- 1) = 0 then
522 if Debug_Flag_Tree
then
523 Write_Str
("==> zeroes: ");
525 Write_Str
(", starting at ");
526 Write_Int
(IP
- Int
(C
));
530 Write_Byte
(C_Zeros
+ C
);
532 elsif Data
(IP
- 1) = Character'Pos (' ') then
533 if Debug_Flag_Tree
then
534 Write_Str
("==> spaces: ");
536 Write_Str
(", starting at ");
537 Write_Int
(IP
- Int
(C
));
541 Write_Byte
(C_Spaces
+ C
);
544 if Debug_Flag_Tree
then
545 Write_Str
("==> other char: ");
548 Write_Int
(Int
(Data
(IP
- 1)));
550 Write_Str
(", starting at ");
551 Write_Int
(IP
- Int
(C
));
555 Write_Byte
(C_Repeat
+ C
);
556 Write_Byte
(Data
(IP
- 1));
559 -- No compression possible here
562 -- Output non-compressed sequence if at maximum length
564 if NC
= Max_Count
then
565 Write_Non_Compressed_Sequence
;
575 ---------------------------
576 -- Tree_Write_Initialize --
577 ---------------------------
579 procedure Tree_Write_Initialize
(Desc
: File_Descriptor
) is
584 Debug_Flag_Tree
:= Debug_Flag_5
;
585 end Tree_Write_Initialize
;
591 procedure Tree_Write_Int
(N
: Int
) is
592 N_Bytes
: constant Int_Bytes
:= To_Int_Bytes
(N
);
595 if Debug_Flag_Tree
then
596 Write_Str
("==> transmitting Int = ");
602 Write_Byte
(N_Bytes
(J
));
610 procedure Tree_Write_Str
(S
: String_Ptr
) is
612 Tree_Write_Int
(S
'Length);
613 Tree_Write_Data
(S
(1)'Address, S
'Length);
616 --------------------------
617 -- Tree_Write_Terminate --
618 --------------------------
620 procedure Tree_Write_Terminate
is
625 end Tree_Write_Terminate
;
631 procedure Write_Buffer
is
633 if Integer (Bufn
) = Write
(Tree_FD
, Buf
'Address, Integer (Bufn
)) then
638 Write_Str
("fatal error: disk full");
647 procedure Write_Byte
(B
: Byte
) is
652 if Bufn
= Buflen
then