URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [tree_io.adb] - Blame information for rev 300

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              T R E E _ I O                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009  Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Debug;  use Debug;
with Output; use Output;
with Unchecked_Conversion;
 
package body Tree_IO is
   Debug_Flag_Tree : Boolean := False;
   --  Debug flag for debug output from tree read/write
 
   -------------------------------------------
   -- Compression Scheme Used for Tree File --
   -------------------------------------------
 
   --  We don't just write the data directly, but instead do a mild form
   --  of compression, since we expect lots of compressible zeroes and
   --  blanks. The compression scheme is as follows:
 
   --    00nnnnnn followed by nnnnnn bytes (non compressed data)
   --    01nnnnnn indicates nnnnnn binary zero bytes
   --    10nnnnnn indicates nnnnnn ASCII space bytes
   --    11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb
 
   --  Since we expect many zeroes in trees, and many spaces in sources,
   --  this compression should be reasonably efficient. We can put in
   --  something better later on.
 
   --  Note that this compression applies to the Write_Tree_Data and
   --  Read_Tree_Data calls, not to the calls to read and write single
   --  scalar values, which are written in memory format without any
   --  compression.
 
   C_Noncomp : constant := 2#00_000000#;
   C_Zeros   : constant := 2#01_000000#;
   C_Spaces  : constant := 2#10_000000#;
   C_Repeat  : constant := 2#11_000000#;
   --  Codes for compression sequences
 
   Max_Count : constant := 63;
   --  Maximum data length for one compression sequence
 
   --  The above compression scheme applies only to data written with the
   --  Tree_Write routine and read with Tree_Read. Data written using the
   --  Tree_Write_Char or Tree_Write_Int routines and read using the
   --  corresponding input routines is not compressed.
 
   type Int_Bytes is array (1 .. 4) of Byte;
   for Int_Bytes'Size use 32;
 
   function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);
   function To_Int       is new Unchecked_Conversion (Int_Bytes, Int);
 
   ----------------------
   -- Global Variables --
   ----------------------
 
   Tree_FD : File_Descriptor;
   --  File descriptor for tree
 
   Buflen : constant Int := 8_192;
   --  Length of buffer for read and write file data
 
   Buf : array (Pos range 1 .. Buflen) of Byte;
   --  Read/write file data buffer
 
   Bufn : Nat;
   --  Number of bytes read/written from/to buffer
 
   Buft : Nat;
   --  Total number of bytes in input buffer containing valid data. Used only
   --  for input operations. There is data left to be processed in the buffer
   --  if Buft > Bufn. A value of zero for Buft means that the buffer is empty.
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   procedure Read_Buffer;
   --  Reads data into buffer, setting Bufn appropriately
 
   function Read_Byte return Byte;
   pragma Inline (Read_Byte);
   --  Returns next byte from input file, raises Tree_Format_Error if none left
 
   procedure Write_Buffer;
   --  Writes out current buffer contents
 
   procedure Write_Byte (B : Byte);
   pragma Inline (Write_Byte);
   --  Write one byte to output buffer, checking for buffer-full condition
 
   -----------------
   -- Read_Buffer --
   -----------------
 
   procedure Read_Buffer is
   begin
      Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));
 
      if Buft = 0 then
         raise Tree_Format_Error;
      else
         Bufn := 0;
      end if;
   end Read_Buffer;
 
   ---------------
   -- Read_Byte --
   ---------------
 
   function Read_Byte return Byte is
   begin
      if Bufn = Buft then
         Read_Buffer;
      end if;
 
      Bufn := Bufn + 1;
      return Buf (Bufn);
   end Read_Byte;
 
   --------------------
   -- Tree_Read_Bool --
   --------------------
 
   procedure Tree_Read_Bool (B : out Boolean) is
   begin
      B := Boolean'Val (Read_Byte);
 
      if Debug_Flag_Tree then
         if B then
            Write_Str ("True");
         else
            Write_Str ("False");
         end if;
 
         Write_Eol;
      end if;
   end Tree_Read_Bool;
 
   --------------------
   -- Tree_Read_Char --
   --------------------
 
   procedure Tree_Read_Char (C : out Character) is
   begin
      C := Character'Val (Read_Byte);
 
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting Character = ");
         Write_Char (C);
         Write_Eol;
      end if;
   end Tree_Read_Char;
 
   --------------------
   -- Tree_Read_Data --
   --------------------
 
   procedure Tree_Read_Data (Addr : Address; Length : Int) is
 
      type S is array (Pos) of Byte;
      --  This is a big array, for which we have to suppress the warning
 
      type SP is access all S;
 
      function To_SP is new Unchecked_Conversion (Address, SP);
 
      Data : constant SP := To_SP (Addr);
      --  Data buffer to be read as an indexable array of bytes
 
      OP : Pos := 1;
      --  Pointer to next byte of data buffer to be read into
 
      B : Byte;
      C : Byte;
      L : Int;
 
   begin
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting ");
         Write_Int (Length);
         Write_Str (" data bytes");
         Write_Eol;
      end if;
 
      --  Verify data length
 
      Tree_Read_Int (L);
 
      if L /= Length then
         Write_Str ("==> transmitting, expected ");
         Write_Int (Length);
         Write_Str (" bytes, found length = ");
         Write_Int (L);
         Write_Eol;
         raise Tree_Format_Error;
      end if;
 
      --  Loop to read data
 
      while OP <= Length loop
 
         --  Get compression control character
 
         B := Read_Byte;
         C := B and 2#00_111111#;
         B := B and 2#11_000000#;
 
         --  Non-repeat case
 
         if B = C_Noncomp then
            if Debug_Flag_Tree then
               Write_Str ("==>    uncompressed:  ");
               Write_Int (Int (C));
               Write_Str (", starting at ");
               Write_Int (OP);
               Write_Eol;
            end if;
 
            for J in 1 .. C loop
               Data (OP) := Read_Byte;
               OP := OP + 1;
            end loop;
 
         --  Repeated zeroes
 
         elsif B = C_Zeros then
            if Debug_Flag_Tree then
               Write_Str ("==>    zeroes:        ");
               Write_Int (Int (C));
               Write_Str (", starting at ");
               Write_Int (OP);
               Write_Eol;
            end if;
 
            for J in 1 .. C loop
               Data (OP) := 0;
               OP := OP + 1;
            end loop;
 
         --  Repeated spaces
 
         elsif B = C_Spaces then
            if Debug_Flag_Tree then
               Write_Str ("==>    spaces:        ");
               Write_Int (Int (C));
               Write_Str (", starting at ");
               Write_Int (OP);
               Write_Eol;
            end if;
 
            for J in 1 .. C loop
               Data (OP) := Character'Pos (' ');
               OP := OP + 1;
            end loop;
 
         --  Specified repeated character
 
         else -- B = C_Repeat
            B := Read_Byte;
 
            if Debug_Flag_Tree then
               Write_Str ("==>    other char:    ");
               Write_Int (Int (C));
               Write_Str (" (");
               Write_Int (Int (B));
               Write_Char (')');
               Write_Str (", starting at ");
               Write_Int (OP);
               Write_Eol;
            end if;
 
            for J in 1 .. C loop
               Data (OP) := B;
               OP := OP + 1;
            end loop;
         end if;
      end loop;
 
      --  At end of loop, data item must be exactly filled
 
      if OP /= Length + 1 then
         raise Tree_Format_Error;
      end if;
 
   end Tree_Read_Data;
 
   --------------------------
   -- Tree_Read_Initialize --
   --------------------------
 
   procedure Tree_Read_Initialize (Desc : File_Descriptor) is
   begin
      Buft := 0;
      Bufn := 0;
      Tree_FD := Desc;
      Debug_Flag_Tree := Debug_Flag_5;
   end Tree_Read_Initialize;
 
   -------------------
   -- Tree_Read_Int --
   -------------------
 
   procedure Tree_Read_Int (N : out Int) is
      N_Bytes : Int_Bytes;
 
   begin
      for J in 1 .. 4 loop
         N_Bytes (J) := Read_Byte;
      end loop;
 
      N := To_Int (N_Bytes);
 
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting Int = ");
         Write_Int (N);
         Write_Eol;
      end if;
   end Tree_Read_Int;
 
   -------------------
   -- Tree_Read_Str --
   -------------------
 
   procedure Tree_Read_Str (S : out String_Ptr) is
      N : Nat;
 
   begin
      Tree_Read_Int (N);
      S := new String (1 .. Natural (N));
      Tree_Read_Data (S.all (1)'Address, N);
   end Tree_Read_Str;
 
   -------------------------
   -- Tree_Read_Terminate --
   -------------------------
 
   procedure Tree_Read_Terminate is
   begin
      --  Must be at end of input buffer, so we should get Tree_Format_Error
      --  if we try to read one more byte, if not, we have a format error.
 
      declare
         B : Byte;
         pragma Warnings (Off, B);
 
      begin
         B := Read_Byte;
 
      exception
         when Tree_Format_Error => return;
      end;
 
      raise Tree_Format_Error;
   end Tree_Read_Terminate;
 
   ---------------------
   -- Tree_Write_Bool --
   ---------------------
 
   procedure Tree_Write_Bool (B : Boolean) is
   begin
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting Boolean = ");
 
         if B then
            Write_Str ("True");
         else
            Write_Str ("False");
         end if;
 
         Write_Eol;
      end if;
 
      Write_Byte (Boolean'Pos (B));
   end Tree_Write_Bool;
 
   ---------------------
   -- Tree_Write_Char --
   ---------------------
 
   procedure Tree_Write_Char (C : Character) is
   begin
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting Character = ");
         Write_Char (C);
         Write_Eol;
      end if;
 
      Write_Byte (Character'Pos (C));
   end Tree_Write_Char;
 
   ---------------------
   -- Tree_Write_Data --
   ---------------------
 
   procedure Tree_Write_Data (Addr : Address; Length : Int) is
 
      type S is array (Pos) of Byte;
      --  This is a big array, for which we have to suppress the warning
 
      type SP is access all S;
 
      function To_SP is new Unchecked_Conversion (Address, SP);
 
      Data : constant SP := To_SP (Addr);
      --  Pointer to data to be written, converted to array type
 
      IP : Pos := 1;
      --  Input buffer pointer, next byte to be processed
 
      NC : Nat range 0 .. Max_Count := 0;
      --  Number of bytes of non-compressible sequence
 
      C  : Byte;
 
      procedure Write_Non_Compressed_Sequence;
      --  Output currently collected sequence of non-compressible data
 
      -----------------------------------
      -- Write_Non_Compressed_Sequence --
      -----------------------------------
 
      procedure Write_Non_Compressed_Sequence is
      begin
         if NC > 0 then
            Write_Byte (C_Noncomp + Byte (NC));
 
            if Debug_Flag_Tree then
               Write_Str ("==>    uncompressed:  ");
               Write_Int (NC);
               Write_Str (", starting at ");
               Write_Int (IP - NC);
               Write_Eol;
            end if;
 
            for J in reverse 1 .. NC loop
               Write_Byte (Data (IP - J));
            end loop;
 
            NC := 0;
         end if;
      end Write_Non_Compressed_Sequence;
 
   --  Start of processing for Tree_Write_Data
 
   begin
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting ");
         Write_Int (Length);
         Write_Str (" data bytes");
         Write_Eol;
      end if;
 
      --  We write the count at the start, so that we can check it on
      --  the corresponding read to make sure that reads and writes match
 
      Tree_Write_Int (Length);
 
      --  Conversion loop
      --    IP is index of next input character
      --    NC is number of non-compressible bytes saved up
 
      loop
         --  If input is completely processed, then we are all done
 
         if IP > Length then
            Write_Non_Compressed_Sequence;
            return;
         end if;
 
         --  Test for compressible sequence, must be at least three identical
         --  bytes in a row to be worthwhile compressing.
 
         if IP + 2 <= Length
           and then Data (IP) = Data (IP + 1)
           and then Data (IP) = Data (IP + 2)
         then
            Write_Non_Compressed_Sequence;
 
            --  Count length of new compression sequence
 
            C := 3;
            IP := IP + 3;
 
            while IP < Length
              and then Data (IP) = Data (IP - 1)
              and then C < Max_Count
            loop
               C := C + 1;
               IP := IP + 1;
            end loop;
 
            --  Output compression sequence
 
            if Data (IP - 1) = 0 then
               if Debug_Flag_Tree then
                  Write_Str ("==>    zeroes:        ");
                  Write_Int (Int (C));
                  Write_Str (", starting at ");
                  Write_Int (IP - Int (C));
                  Write_Eol;
               end if;
 
               Write_Byte (C_Zeros + C);
 
            elsif Data (IP - 1) = Character'Pos (' ') then
               if Debug_Flag_Tree then
                  Write_Str ("==>    spaces:        ");
                  Write_Int (Int (C));
                  Write_Str (", starting at ");
                  Write_Int (IP - Int (C));
                  Write_Eol;
               end if;
 
               Write_Byte (C_Spaces + C);
 
            else
               if Debug_Flag_Tree then
                  Write_Str ("==>    other char:    ");
                  Write_Int (Int (C));
                  Write_Str (" (");
                  Write_Int (Int (Data (IP - 1)));
                  Write_Char (')');
                  Write_Str (", starting at ");
                  Write_Int (IP - Int (C));
                  Write_Eol;
               end if;
 
               Write_Byte (C_Repeat + C);
               Write_Byte (Data (IP - 1));
            end if;
 
         --  No compression possible here
 
         else
            --  Output non-compressed sequence if at maximum length
 
            if NC = Max_Count then
               Write_Non_Compressed_Sequence;
            end if;
 
            NC := NC + 1;
            IP := IP + 1;
         end if;
      end loop;
 
   end Tree_Write_Data;
 
   ---------------------------
   -- Tree_Write_Initialize --
   ---------------------------
 
   procedure Tree_Write_Initialize (Desc : File_Descriptor) is
   begin
      Bufn := 0;
      Tree_FD := Desc;
      Set_Standard_Error;
      Debug_Flag_Tree := Debug_Flag_5;
   end Tree_Write_Initialize;
 
   --------------------
   -- Tree_Write_Int --
   --------------------
 
   procedure Tree_Write_Int (N : Int) is
      N_Bytes : constant Int_Bytes := To_Int_Bytes (N);
 
   begin
      if Debug_Flag_Tree then
         Write_Str ("==> transmitting Int = ");
         Write_Int (N);
         Write_Eol;
      end if;
 
      for J in 1 .. 4 loop
         Write_Byte (N_Bytes (J));
      end loop;
   end Tree_Write_Int;
 
   --------------------
   -- Tree_Write_Str --
   --------------------
 
   procedure Tree_Write_Str (S : String_Ptr) is
   begin
      Tree_Write_Int (S'Length);
      Tree_Write_Data (S (1)'Address, S'Length);
   end Tree_Write_Str;
 
   --------------------------
   -- Tree_Write_Terminate --
   --------------------------
 
   procedure Tree_Write_Terminate is
   begin
      if Bufn > 0 then
         Write_Buffer;
      end if;
   end Tree_Write_Terminate;
 
   ------------------
   -- Write_Buffer --
   ------------------
 
   procedure Write_Buffer is
   begin
      if Integer (Bufn) = Write (Tree_FD, Buf'Address, Integer (Bufn)) then
         Bufn := 0;
 
      else
         Set_Standard_Error;
         Write_Str ("fatal error: disk full");
         OS_Exit (2);
      end if;
   end Write_Buffer;
 
   ----------------
   -- Write_Byte --
   ----------------
 
   procedure Write_Byte (B : Byte) is
   begin
      Bufn := Bufn + 1;
      Buf (Bufn) := B;
 
      if Bufn = Buflen then
         Write_Buffer;
      end if;
   end Write_Byte;
 
end Tree_IO;

Browse

Tools

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [tree_io.adb] - Blame information for rev 300

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- T R E E _ I O --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009 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 3, 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. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`with Debug; use Debug;`
33			`with Output; use Output;`
34			`with Unchecked_Conversion;`
35
36			`package body Tree_IO is`
37			`Debug_Flag_Tree : Boolean := False;`
38			`-- Debug flag for debug output from tree read/write`
39
40			`-------------------------------------------`
41			`-- Compression Scheme Used for Tree File --`
42			`-------------------------------------------`
43
44			`-- We don't just write the data directly, but instead do a mild form`
45			`-- of compression, since we expect lots of compressible zeroes and`
46			`-- blanks. The compression scheme is as follows:`
47
48			`-- 00nnnnnn followed by nnnnnn bytes (non compressed data)`
49			`-- 01nnnnnn indicates nnnnnn binary zero bytes`
50			`-- 10nnnnnn indicates nnnnnn ASCII space bytes`
51			`-- 11nnnnnn bbbbbbbb indicates nnnnnnnn occurrences of byte bbbbbbbb`
52
53			`-- Since we expect many zeroes in trees, and many spaces in sources,`
54			`-- this compression should be reasonably efficient. We can put in`
55			`-- something better later on.`
56
57			`-- Note that this compression applies to the Write_Tree_Data and`
58			`-- Read_Tree_Data calls, not to the calls to read and write single`
59			`-- scalar values, which are written in memory format without any`
60			`-- compression.`
61
62			`C_Noncomp : constant := 2#00_000000#;`
63			`C_Zeros : constant := 2#01_000000#;`
64			`C_Spaces : constant := 2#10_000000#;`
65			`C_Repeat : constant := 2#11_000000#;`
66			`-- Codes for compression sequences`
67
68			`Max_Count : constant := 63;`
69			`-- Maximum data length for one compression sequence`
70
71			`-- The above compression scheme applies only to data written with the`
72			`-- Tree_Write routine and read with Tree_Read. Data written using the`
73			`-- Tree_Write_Char or Tree_Write_Int routines and read using the`
74			`-- corresponding input routines is not compressed.`
75
76			`type Int_Bytes is array (1 .. 4) of Byte;`
77			`for Int_Bytes'Size use 32;`
78
79			`function To_Int_Bytes is new Unchecked_Conversion (Int, Int_Bytes);`
80			`function To_Int is new Unchecked_Conversion (Int_Bytes, Int);`
81
82			`----------------------`
83			`-- Global Variables --`
84			`----------------------`
85
86			`Tree_FD : File_Descriptor;`
87			`-- File descriptor for tree`
88
89			`Buflen : constant Int := 8_192;`
90			`-- Length of buffer for read and write file data`
91
92			`Buf : array (Pos range 1 .. Buflen) of Byte;`
93			`-- Read/write file data buffer`
94
95			`Bufn : Nat;`
96			`-- Number of bytes read/written from/to buffer`
97
98			`Buft : Nat;`
99			`-- Total number of bytes in input buffer containing valid data. Used only`
100			`-- for input operations. There is data left to be processed in the buffer`
101			`-- if Buft > Bufn. A value of zero for Buft means that the buffer is empty.`
102
103			`-----------------------`
104			`-- Local Subprograms --`
105			`-----------------------`
106
107			`procedure Read_Buffer;`
108			`-- Reads data into buffer, setting Bufn appropriately`
109
110			`function Read_Byte return Byte;`
111			`pragma Inline (Read_Byte);`
112			`-- Returns next byte from input file, raises Tree_Format_Error if none left`
113
114			`procedure Write_Buffer;`
115			`-- Writes out current buffer contents`
116
117			`procedure Write_Byte (B : Byte);`
118			`pragma Inline (Write_Byte);`
119			`-- Write one byte to output buffer, checking for buffer-full condition`
120
121			`-----------------`
122			`-- Read_Buffer --`
123			`-----------------`
124
125			`procedure Read_Buffer is`
126			`begin`
127			`Buft := Int (Read (Tree_FD, Buf (1)'Address, Integer (Buflen)));`
128
129			`if Buft = 0 then`
130			`raise Tree_Format_Error;`
131			`else`
132			`Bufn := 0;`
133			`end if;`
134			`end Read_Buffer;`
135
136			`---------------`
137			`-- Read_Byte --`
138			`---------------`
139
140			`function Read_Byte return Byte is`
141			`begin`
142			`if Bufn = Buft then`
143			`Read_Buffer;`
144			`end if;`
145
146			`Bufn := Bufn + 1;`
147			`return Buf (Bufn);`
148			`end Read_Byte;`
149
150			`--------------------`
151			`-- Tree_Read_Bool --`
152			`--------------------`
153
154			`procedure Tree_Read_Bool (B : out Boolean) is`
155			`begin`
156			`B := Boolean'Val (Read_Byte);`
157
158			`if Debug_Flag_Tree then`
159			`if B then`
160			`Write_Str ("True");`
161			`else`
162			`Write_Str ("False");`
163			`end if;`
164
165			`Write_Eol;`
166			`end if;`
167			`end Tree_Read_Bool;`
168
169			`--------------------`
170			`-- Tree_Read_Char --`
171			`--------------------`
172
173			`procedure Tree_Read_Char (C : out Character) is`
174			`begin`
175			`C := Character'Val (Read_Byte);`
176
177			`if Debug_Flag_Tree then`
178			`Write_Str ("==> transmitting Character = ");`
179			`Write_Char (C);`
180			`Write_Eol;`
181			`end if;`
182			`end Tree_Read_Char;`
183
184			`--------------------`
185			`-- Tree_Read_Data --`
186			`--------------------`
187
188			`procedure Tree_Read_Data (Addr : Address; Length : Int) is`
189
190			`type S is array (Pos) of Byte;`
191			`-- This is a big array, for which we have to suppress the warning`
192
193			`type SP is access all S;`
194
195			`function To_SP is new Unchecked_Conversion (Address, SP);`
196
197			`Data : constant SP := To_SP (Addr);`
198			`-- Data buffer to be read as an indexable array of bytes`
199
200			`OP : Pos := 1;`
201			`-- Pointer to next byte of data buffer to be read into`
202
203			`B : Byte;`
204			`C : Byte;`
205			`L : Int;`
206
207			`begin`
208			`if Debug_Flag_Tree then`
209			`Write_Str ("==> transmitting ");`
210			`Write_Int (Length);`
211			`Write_Str (" data bytes");`
212			`Write_Eol;`
213			`end if;`
214
215			`-- Verify data length`
216
217			`Tree_Read_Int (L);`
218
219			`if L /= Length then`
220			`Write_Str ("==> transmitting, expected ");`
221			`Write_Int (Length);`
222			`Write_Str (" bytes, found length = ");`
223			`Write_Int (L);`
224			`Write_Eol;`
225			`raise Tree_Format_Error;`
226			`end if;`
227
228			`-- Loop to read data`
229
230			`while OP <= Length loop`
231
232			`-- Get compression control character`
233
234			`B := Read_Byte;`
235			`C := B and 2#00_111111#;`
236			`B := B and 2#11_000000#;`
237
238			`-- Non-repeat case`
239
240			`if B = C_Noncomp then`
241			`if Debug_Flag_Tree then`
242			`Write_Str ("==> uncompressed: ");`
243			`Write_Int (Int (C));`
244			`Write_Str (", starting at ");`
245			`Write_Int (OP);`
246			`Write_Eol;`
247			`end if;`
248
249			`for J in 1 .. C loop`
250			`Data (OP) := Read_Byte;`
251			`OP := OP + 1;`
252			`end loop;`
253
254			`-- Repeated zeroes`
255
256			`elsif B = C_Zeros then`
257			`if Debug_Flag_Tree then`
258			`Write_Str ("==> zeroes: ");`
259			`Write_Int (Int (C));`
260			`Write_Str (", starting at ");`
261			`Write_Int (OP);`
262			`Write_Eol;`
263			`end if;`
264
265			`for J in 1 .. C loop`
266			`Data (OP) := 0;`
267			`OP := OP + 1;`
268			`end loop;`
269
270			`-- Repeated spaces`
271
272			`elsif B = C_Spaces then`
273			`if Debug_Flag_Tree then`
274			`Write_Str ("==> spaces: ");`
275			`Write_Int (Int (C));`
276			`Write_Str (", starting at ");`
277			`Write_Int (OP);`
278			`Write_Eol;`
279			`end if;`
280
281			`for J in 1 .. C loop`
282			`Data (OP) := Character'Pos (' ');`
283			`OP := OP + 1;`
284			`end loop;`
285
286			`-- Specified repeated character`
287
288			`else -- B = C_Repeat`
289			`B := Read_Byte;`
290
291			`if Debug_Flag_Tree then`
292			`Write_Str ("==> other char: ");`
293			`Write_Int (Int (C));`
294			`Write_Str (" (");`
295			`Write_Int (Int (B));`
296			`Write_Char (')');`
297			`Write_Str (", starting at ");`
298			`Write_Int (OP);`
299			`Write_Eol;`
300			`end if;`
301
302			`for J in 1 .. C loop`
303			`Data (OP) := B;`
304			`OP := OP + 1;`
305			`end loop;`
306			`end if;`
307			`end loop;`
308
309			`-- At end of loop, data item must be exactly filled`
310
311			`if OP /= Length + 1 then`
312			`raise Tree_Format_Error;`
313			`end if;`
314
315			`end Tree_Read_Data;`
316
317			`--------------------------`
318			`-- Tree_Read_Initialize --`
319			`--------------------------`
320
321			`procedure Tree_Read_Initialize (Desc : File_Descriptor) is`
322			`begin`
323			`Buft := 0;`
324			`Bufn := 0;`
325			`Tree_FD := Desc;`
326			`Debug_Flag_Tree := Debug_Flag_5;`
327			`end Tree_Read_Initialize;`
328
329			`-------------------`
330			`-- Tree_Read_Int --`
331			`-------------------`
332
333			`procedure Tree_Read_Int (N : out Int) is`
334			`N_Bytes : Int_Bytes;`
335
336			`begin`
337			`for J in 1 .. 4 loop`
338			`N_Bytes (J) := Read_Byte;`
339			`end loop;`
340
341			`N := To_Int (N_Bytes);`
342
343			`if Debug_Flag_Tree then`
344			`Write_Str ("==> transmitting Int = ");`
345			`Write_Int (N);`
346			`Write_Eol;`
347			`end if;`
348			`end Tree_Read_Int;`
349
350			`-------------------`
351			`-- Tree_Read_Str --`
352			`-------------------`
353
354			`procedure Tree_Read_Str (S : out String_Ptr) is`
355			`N : Nat;`
356
357			`begin`
358			`Tree_Read_Int (N);`
359			`S := new String (1 .. Natural (N));`
360			`Tree_Read_Data (S.all (1)'Address, N);`
361			`end Tree_Read_Str;`
362
363			`-------------------------`
364			`-- Tree_Read_Terminate --`
365			`-------------------------`
366
367			`procedure Tree_Read_Terminate is`
368			`begin`
369			`-- Must be at end of input buffer, so we should get Tree_Format_Error`
370			`-- if we try to read one more byte, if not, we have a format error.`
371
372			`declare`
373			`B : Byte;`
374			`pragma Warnings (Off, B);`
375
376			`begin`
377			`B := Read_Byte;`
378
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			`-----------------------------------`
450			`-- Write_Non_Compressed_Sequence --`
451			`-----------------------------------`
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;`