home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / stringt.adb < prev    next >
Text File  |  1996-09-28  |  9KB  |  302 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              S T R I N G T                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.28 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Alloc;  use Alloc;
  27. with Output; use Output;
  28.  
  29. package body Stringt is
  30.  
  31.    --  The following table stores the sequence of character codes for the
  32.    --  stored string constants. The entries are referenced from the
  33.    --  separate Strings table.
  34.  
  35.    package String_Chars is new Table (
  36.      Table_Component_Type => Char_Code,
  37.      Table_Index_Type     => Int,
  38.      Table_Low_Bound      => 0,
  39.      Table_Initial        => Alloc_String_Chars_Initial,
  40.      Table_Increment      => Alloc_String_Chars_Increment,
  41.      Table_Name           => "String_Chars");
  42.  
  43.    --  The String_Id values reference entries in the Strings table, which
  44.    --  contains String_Entry records that record the length of each stored
  45.    --  string and its starting location in the String_Chars table.
  46.  
  47.    type String_Entry is record
  48.       String_Index : Int;
  49.       Length       : Nat;
  50.    end record;
  51.  
  52.    package Strings is new Table (
  53.      Table_Component_Type => String_Entry,
  54.      Table_Index_Type     => String_Id,
  55.      Table_Low_Bound      => First_String_Id,
  56.      Table_Initial        => Alloc_Strings_Initial,
  57.      Table_Increment      => Alloc_Strings_Increment,
  58.      Table_Name           => "Strings");
  59.  
  60.    --  Note: it is possible that two entries in the Strings table can share
  61.    --  string data in the String_Chars table, and in particular this happens
  62.    --  when Start_String is called with a parameter that is the last string
  63.    --  currently allocated in the table.
  64.  
  65.    ----------------
  66.    -- End_String --
  67.    ----------------
  68.  
  69.    function End_String return String_Id is
  70.    begin
  71.       return Strings.Last;
  72.    end End_String;
  73.  
  74.    ---------------------
  75.    -- Get_String_Char --
  76.    ---------------------
  77.  
  78.    function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
  79.    begin
  80.       pragma Assert (Id in First_String_Id .. Strings.Last
  81.                        and then Index in 1 .. Strings.Table (Id).Length);
  82.  
  83.       return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
  84.    end Get_String_Char;
  85.  
  86.    ----------------
  87.    -- Initialize --
  88.    ----------------
  89.  
  90.    procedure Initialize is
  91.    begin
  92.       String_Chars.Init;
  93.       Strings.Init;
  94.    end Initialize;
  95.  
  96.    ------------------
  97.    -- Start_String --
  98.    ------------------
  99.  
  100.    procedure Start_String is
  101.    begin
  102.       Strings.Increment_Last;
  103.       Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1;
  104.       Strings.Table (Strings.Last).Length := 0;
  105.    end Start_String;
  106.  
  107.    procedure Start_String (S : String_Id) is
  108.    begin
  109.       Strings.Increment_Last;
  110.  
  111.       --  Case of initial string value is at the end of the string characters
  112.       --  table, so it does not need copying, instead it can be shared.
  113.  
  114.       if Strings.Table (S).String_Index + Strings.Table (S).Length =
  115.                                                     String_Chars.Last + 1
  116.       then
  117.          Strings.Table (Strings.Last).String_Index :=
  118.            Strings.Table (S).String_Index;
  119.  
  120.       --  Case of initial string value must be copied to new string
  121.  
  122.       else
  123.          Strings.Table (Strings.Last).String_Index :=
  124.            String_Chars.Last + 1;
  125.  
  126.          for J in 1 .. Strings.Table (S).Length loop
  127.             String_Chars.Increment_Last;
  128.             String_Chars.Table (String_Chars.Last) :=
  129.               String_Chars.Table (Strings.Table (S).String_Index + (J - 1));
  130.          end loop;
  131.       end if;
  132.  
  133.       --  In either case the result string length is copied from the argument
  134.  
  135.       Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
  136.    end Start_String;
  137.  
  138.    -----------------------
  139.    -- Store_String_Char --
  140.    -----------------------
  141.  
  142.    procedure Store_String_Char (C : Char_Code) is
  143.    begin
  144.       String_Chars.Increment_Last;
  145.       String_Chars.Table (String_Chars.Last) := C;
  146.       Strings.Table (Strings.Last).Length :=
  147.         Strings.Table (Strings.Last).Length + 1;
  148.    end Store_String_Char;
  149.  
  150.    ------------------------
  151.    -- Store_String_Chars --
  152.    ------------------------
  153.  
  154.    procedure Store_String_Chars (S : String) is
  155.    begin
  156.       for J in S'First .. S'Last loop
  157.          Store_String_Char (Get_Char_Code (S (J)));
  158.       end loop;
  159.    end Store_String_Chars;
  160.  
  161.    --------------------------
  162.    -- String_Chars_Address --
  163.    --------------------------
  164.  
  165.    function String_Chars_Address return System.Address is
  166.    begin
  167.       return String_Chars.Table (0)'Address;
  168.    end String_Chars_Address;
  169.  
  170.    ------------------
  171.    -- String_Equal --
  172.    ------------------
  173.  
  174.    function String_Equal (L, R : String_Id) return Boolean is
  175.       Len : constant Nat := Strings.Table (L).Length;
  176.  
  177.    begin
  178.       if Len /= Strings.Table (R).Length then
  179.          return False;
  180.       else
  181.          for J in 1 .. Len loop
  182.             if Get_String_Char (L, J) /= Get_String_Char (R, J) then
  183.                return False;
  184.             end if;
  185.          end loop;
  186.  
  187.          return True;
  188.       end if;
  189.    end String_Equal;
  190.  
  191.    -------------------
  192.    -- String_Length --
  193.    -------------------
  194.  
  195.    function String_Length (Id : String_Id) return Nat is
  196.    begin
  197.       return Strings.Table (Id).Length;
  198.    end String_Length;
  199.  
  200.    ---------------------
  201.    -- Strings_Address --
  202.    ---------------------
  203.  
  204.    function Strings_Address return System.Address is
  205.    begin
  206.       return Strings.Table (First_String_Id)'Address;
  207.    end Strings_Address;
  208.  
  209.    ---------------
  210.    -- Tree_Read --
  211.    ---------------
  212.  
  213.    procedure Tree_Read is
  214.    begin
  215.       String_Chars.Tree_Read;
  216.       Strings.Tree_Read;
  217.    end Tree_Read;
  218.  
  219.    ----------------
  220.    -- Tree_Write --
  221.    ----------------
  222.  
  223.    procedure Tree_Write is
  224.    begin
  225.       String_Chars.Tree_Write;
  226.       Strings.Tree_Write;
  227.    end Tree_Write;
  228.  
  229.    -------------------------
  230.    -- Unstore_String_Char --
  231.    -------------------------
  232.  
  233.    procedure Unstore_String_Char is
  234.    begin
  235.       String_Chars.Decrement_Last;
  236.       Strings.Table (Strings.Last).Length :=
  237.         Strings.Table (Strings.Last).Length - 1;
  238.    end Unstore_String_Char;
  239.  
  240.    ---------------------
  241.    -- Write_Char_Code --
  242.    ---------------------
  243.  
  244.    procedure Write_Char_Code (Code : Char_Code) is
  245.  
  246.       procedure Write_Hex_Byte (J : Natural);
  247.       --  Write single hex digit
  248.  
  249.       procedure Write_Hex_Byte (J : Natural) is
  250.          Hexd : String := "0123456789abcdef";
  251.  
  252.       begin
  253.          Write_Char (Hexd (J / 16 + 1));
  254.          Write_Char (Hexd (J mod 16 + 1));
  255.       end Write_Hex_Byte;
  256.  
  257.    --  Start of processing for Write_Char_Code
  258.  
  259.    begin
  260.       if Code in 16#20# .. 16#7A#
  261.         or else Code in 16#7C# .. 16#7F#
  262.       then
  263.          Write_Char (Character'Val (Code));
  264.  
  265.       else
  266.          Write_Char ('{');
  267.  
  268.          if Code > 16#FF# then
  269.             Write_Hex_Byte (Natural (Code / 256));
  270.          end if;
  271.  
  272.          Write_Hex_Byte (Natural (Code mod 256));
  273.          Write_Char ('}');
  274.       end if;
  275.    end Write_Char_Code;
  276.  
  277.    ------------------------------
  278.    -- Write_String_Table_Entry --
  279.    ------------------------------
  280.  
  281.    procedure Write_String_Table_Entry (Id : String_Id) is
  282.       C : Char_Code;
  283.  
  284.    begin
  285.       Write_Char ('"');
  286.  
  287.       for I in 1 .. String_Length (Id) loop
  288.          C := Get_String_Char (Id, I);
  289.  
  290.          if Character'Val (C) = '"' then
  291.             Write_Str ("""""");
  292.  
  293.          else
  294.             Write_Char_Code (C);
  295.          end if;
  296.       end loop;
  297.  
  298.       Write_Char ('"');
  299.    end Write_String_Table_Entry;
  300.  
  301. end Stringt;
  302.