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 / namet.adb < prev    next >
Text File  |  1996-09-28  |  31KB  |  935 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                                N A M E T                                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.60 $                             --
  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. --  WARNING: There is a C version of this package. Any changes to this
  27. --  source file must be properly reflected in the C header file namet.h
  28. --  which is created manually from namet.ads and namet.adb.
  29.  
  30. with Alloc;    use Alloc;
  31. with Debug;    use Debug;
  32. with Output;   use Output;
  33. with Tree_IO;  use Tree_IO;
  34. with Widechar; use Widechar;
  35.  
  36. package body Namet is
  37.  
  38.    --  This table stores the actual string names. Although logically there
  39.    --  is no need for a terminating character (since the length is stored
  40.    --  in the name entry table), we still store a NUL character at the end
  41.    --  of every name (for convenience in interfacing to the C world).
  42.  
  43.    package Name_Chars is new Table (
  44.      Table_Component_Type => Character,
  45.      Table_Index_Type     => Int,
  46.      Table_Low_Bound      => 0,
  47.      Table_Initial        => Alloc_Name_Chars_Initial,
  48.      Table_Increment      => Alloc_Name_Chars_Increment,
  49.      Table_Name           => "Name_Chars");
  50.  
  51.    type Name_Entry is record
  52.       Name_Chars_Index : Int;
  53.       --  Starting location of characters in the Name_Chars table minus
  54.       --  one (i.e. pointer to character just before first character). The
  55.       --  reason for the bias of one is that indexes in Name_Buffer are
  56.       --  one's origin, so this avoids unnecessary adds and subtracts of 1.
  57.  
  58.       Name_Len : Short;
  59.       --  Length of this name in characters
  60.  
  61.       Byte_Info : Byte;
  62.       --  Byte value associated with this name
  63.  
  64.       Hash_Link : Name_Id;
  65.       --  Link to next entry in names table for same hash code
  66.  
  67.       Int_Info : Int;
  68.       --  Int Value associated with this name
  69.    end record;
  70.  
  71.    --  This is the table that is referenced by Name_Id entries.
  72.    --  It contains one entry for each unique name in the table.
  73.  
  74.    package Name_Entries is new Table (
  75.      Table_Component_Type => Name_Entry,
  76.      Table_Index_Type     => Name_Id,
  77.      Table_Low_Bound      => First_Name_Id,
  78.      Table_Initial        => Alloc_Names_Initial,
  79.      Table_Increment      => Alloc_Names_Increment,
  80.      Table_Name           => "Name_Entries");
  81.  
  82.    Hash_Num : constant Int := 2**12;
  83.    --  Number of headers in the hash table. Current hash algorithm is closely
  84.    --  tailored to this choice, so it can only be changed if a corresponding
  85.    --  change is made to the hash alogorithm.
  86.  
  87.    Hash_Max : constant Int := Hash_Num - 1;
  88.    --  Indexes in the hash header table run from 0 to Hash_Num - 1
  89.  
  90.    subtype Hash_Index_Type is Int range 0 .. Hash_Max;
  91.    --  Range of hash index values
  92.  
  93.    Hash_Table : array (Hash_Index_Type) of Name_Id;
  94.    --  The hash table is used to locate existing entries in the names table.
  95.    --  The entries point to the first names table entry whose hash value
  96.    --  matches the hash code. Then subsequent names table entries with the
  97.    --  same hash code value are linked through the Hash_Link fields.
  98.  
  99.    -----------------------
  100.    -- Local Subprograms --
  101.    -----------------------
  102.  
  103.    function Hash return Hash_Index_Type;
  104.    pragma Inline (Hash);
  105.    --  Compute hash code for name stored in Name_Buffer (length in Name_Len)
  106.  
  107.    ----------
  108.    -- Hash --
  109.    ----------
  110.  
  111.    function Hash return Hash_Index_Type is
  112.       subtype Int_1_12 is Int range 1 .. 12;
  113.       --  Used to avoid when others on case jump below
  114.  
  115.       Even_Name_Len : Integer;
  116.       --  Last even numbered position (used for >12 case)
  117.  
  118.    begin
  119.  
  120.       --  Special test for 12 (rather than counting on a when others for the
  121.       --  case statement below) avoids some Ada compilers converting the case
  122.       --  statement into successive jumps.
  123.  
  124.       --  The case of a name longer than 12 characters is handled by taking
  125.       --  the first 6 odd numbered characters and the last 6 even numbered
  126.       --  characters
  127.  
  128.       if Name_Len > 12 then
  129.          Even_Name_Len := (Name_Len) / 2 * 2;
  130.  
  131.          return ((((((((((((
  132.            Character'Pos (Name_Buffer (01))) * 2 +
  133.            Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
  134.            Character'Pos (Name_Buffer (03))) * 2 +
  135.            Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
  136.            Character'Pos (Name_Buffer (05))) * 2 +
  137.            Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
  138.            Character'Pos (Name_Buffer (07))) * 2 +
  139.            Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
  140.            Character'Pos (Name_Buffer (09))) * 2 +
  141.            Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
  142.            Character'Pos (Name_Buffer (11))) * 2 +
  143.            Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
  144.       end if;
  145.  
  146.       --  For the cases of 1-12 characters, all characters participate in the
  147.       --  hash. The positioning is randomized, with the bias that characters
  148.       --  later on participate fully (i.e. are added towards the right side).
  149.  
  150.       case (Int_1_12 (Name_Len)) is
  151.  
  152.          when 1 =>
  153.             return
  154.                Character'Pos (Name_Buffer (1));
  155.  
  156.          when 2 =>
  157.             return ((
  158.               Character'Pos (Name_Buffer (1))) * 64 +
  159.               Character'Pos (Name_Buffer (2))) mod Hash_Num;
  160.  
  161.          when 3 =>
  162.             return (((
  163.               Character'Pos (Name_Buffer (1))) * 16 +
  164.               Character'Pos (Name_Buffer (3))) * 16 +
  165.               Character'Pos (Name_Buffer (2))) mod Hash_Num;
  166.  
  167.          when 4 =>
  168.             return ((((
  169.               Character'Pos (Name_Buffer (1))) * 8 +
  170.               Character'Pos (Name_Buffer (2))) * 8 +
  171.               Character'Pos (Name_Buffer (3))) * 8 +
  172.               Character'Pos (Name_Buffer (4))) mod Hash_Num;
  173.  
  174.          when 5 =>
  175.             return (((((
  176.               Character'Pos (Name_Buffer (4))) * 8 +
  177.               Character'Pos (Name_Buffer (1))) * 4 +
  178.               Character'Pos (Name_Buffer (3))) * 4 +
  179.               Character'Pos (Name_Buffer (5))) * 8 +
  180.               Character'Pos (Name_Buffer (2))) mod Hash_Num;
  181.  
  182.          when 6 =>
  183.             return ((((((
  184.               Character'Pos (Name_Buffer (5))) * 4 +
  185.               Character'Pos (Name_Buffer (1))) * 4 +
  186.               Character'Pos (Name_Buffer (4))) * 4 +
  187.               Character'Pos (Name_Buffer (2))) * 4 +
  188.               Character'Pos (Name_Buffer (6))) * 4 +
  189.               Character'Pos (Name_Buffer (3))) mod Hash_Num;
  190.  
  191.          when 7 =>
  192.             return (((((((
  193.               Character'Pos (Name_Buffer (4))) * 4 +
  194.               Character'Pos (Name_Buffer (3))) * 4 +
  195.               Character'Pos (Name_Buffer (1))) * 4 +
  196.               Character'Pos (Name_Buffer (2))) * 2 +
  197.               Character'Pos (Name_Buffer (5))) * 2 +
  198.               Character'Pos (Name_Buffer (7))) * 2 +
  199.               Character'Pos (Name_Buffer (6))) mod Hash_Num;
  200.  
  201.          when 8 =>
  202.             return ((((((((
  203.               Character'Pos (Name_Buffer (2))) * 4 +
  204.               Character'Pos (Name_Buffer (1))) * 4 +
  205.               Character'Pos (Name_Buffer (3))) * 2 +
  206.               Character'Pos (Name_Buffer (5))) * 2 +
  207.               Character'Pos (Name_Buffer (7))) * 2 +
  208.               Character'Pos (Name_Buffer (6))) * 2 +
  209.               Character'Pos (Name_Buffer (4))) * 2 +
  210.               Character'Pos (Name_Buffer (8))) mod Hash_Num;
  211.  
  212.          when 9 =>
  213.             return (((((((((
  214.               Character'Pos (Name_Buffer (2))) * 4 +
  215.               Character'Pos (Name_Buffer (1))) * 4 +
  216.               Character'Pos (Name_Buffer (3))) * 4 +
  217.               Character'Pos (Name_Buffer (4))) * 2 +
  218.               Character'Pos (Name_Buffer (8))) * 2 +
  219.               Character'Pos (Name_Buffer (7))) * 2 +
  220.               Character'Pos (Name_Buffer (5))) * 2 +
  221.               Character'Pos (Name_Buffer (6))) * 2 +
  222.               Character'Pos (Name_Buffer (9))) mod Hash_Num;
  223.  
  224.          when 10 =>
  225.             return ((((((((((
  226.               Character'Pos (Name_Buffer (01))) * 2 +
  227.               Character'Pos (Name_Buffer (02))) * 2 +
  228.               Character'Pos (Name_Buffer (08))) * 2 +
  229.               Character'Pos (Name_Buffer (03))) * 2 +
  230.               Character'Pos (Name_Buffer (04))) * 2 +
  231.               Character'Pos (Name_Buffer (09))) * 2 +
  232.               Character'Pos (Name_Buffer (06))) * 2 +
  233.               Character'Pos (Name_Buffer (05))) * 2 +
  234.               Character'Pos (Name_Buffer (07))) * 2 +
  235.               Character'Pos (Name_Buffer (10))) mod Hash_Num;
  236.  
  237.          when 11 =>
  238.             return (((((((((((
  239.               Character'Pos (Name_Buffer (05))) * 2 +
  240.               Character'Pos (Name_Buffer (01))) * 2 +
  241.               Character'Pos (Name_Buffer (06))) * 2 +
  242.               Character'Pos (Name_Buffer (09))) * 2 +
  243.               Character'Pos (Name_Buffer (07))) * 2 +
  244.               Character'Pos (Name_Buffer (03))) * 2 +
  245.               Character'Pos (Name_Buffer (08))) * 2 +
  246.               Character'Pos (Name_Buffer (02))) * 2 +
  247.               Character'Pos (Name_Buffer (10))) * 2 +
  248.               Character'Pos (Name_Buffer (04))) * 2 +
  249.               Character'Pos (Name_Buffer (11))) mod Hash_Num;
  250.  
  251.          when 12 =>
  252.             return ((((((((((((
  253.               Character'Pos (Name_Buffer (03))) * 2 +
  254.               Character'Pos (Name_Buffer (02))) * 2 +
  255.               Character'Pos (Name_Buffer (05))) * 2 +
  256.               Character'Pos (Name_Buffer (01))) * 2 +
  257.               Character'Pos (Name_Buffer (06))) * 2 +
  258.               Character'Pos (Name_Buffer (04))) * 2 +
  259.               Character'Pos (Name_Buffer (08))) * 2 +
  260.               Character'Pos (Name_Buffer (11))) * 2 +
  261.               Character'Pos (Name_Buffer (07))) * 2 +
  262.               Character'Pos (Name_Buffer (09))) * 2 +
  263.               Character'Pos (Name_Buffer (10))) * 2 +
  264.               Character'Pos (Name_Buffer (12))) mod Hash_Num;
  265.  
  266.       end case;
  267.    end Hash;
  268.  
  269.    --------------
  270.    -- Finalize --
  271.    --------------
  272.  
  273.    procedure Finalize is
  274.       Max_Chain_Length : constant := 50;
  275.       --  Max length of chains for which specific information is output
  276.  
  277.       F : array (Int range 0 .. Max_Chain_Length) of Int;
  278.       --  N'th entry is number of chains of length N
  279.  
  280.       Probes : Int := 0;
  281.       --  Used to compute average number of probes
  282.  
  283.       Nsyms : Int := 0;
  284.       --  Number of symbols in table
  285.  
  286.    begin
  287.       if Debug_Flag_H then
  288.  
  289.          for J in F'Range loop
  290.             F (J) := 0;
  291.          end loop;
  292.  
  293.          for I in Hash_Index_Type loop
  294.             if Hash_Table (I) = No_Name then
  295.                F (0) := F (0) + 1;
  296.  
  297.             else
  298.                Write_Str ("Hash_Table (");
  299.                Write_Int (Int (I));
  300.                Write_Str (") has ");
  301.  
  302.                declare
  303.                   C : Int := 1;
  304.                   N : Name_Id;
  305.                   S : Int;
  306.  
  307.                begin
  308.                   C := 0;
  309.                   N := Hash_Table (I);
  310.  
  311.                   while N /= No_Name loop
  312.                      N := Name_Entries.Table (N).Hash_Link;
  313.                      C := C + 1;
  314.                   end loop;
  315.  
  316.                   Write_Int (C);
  317.                   Write_Str (" entries");
  318.                   Write_Eol;
  319.  
  320.                   if C < Max_Chain_Length then
  321.                      F (C) := F (C) + 1;
  322.                   else
  323.                      F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
  324.                   end if;
  325.  
  326.                   N := Hash_Table (I);
  327.  
  328.                   while N /= No_Name loop
  329.                      S := Name_Entries.Table (N).Name_Chars_Index;
  330.                      Write_Str ("      ");
  331.  
  332.                      for J in 1 .. Name_Entries.Table (N).Name_Len loop
  333.                         Write_Char (Name_Chars.Table (S + Int (J)));
  334.                      end loop;
  335.  
  336.                      Write_Eol;
  337.                      N := Name_Entries.Table (N).Hash_Link;
  338.                   end loop;
  339.                end;
  340.             end if;
  341.          end loop;
  342.  
  343.          Write_Eol;
  344.  
  345.          for I in Int range 0 .. Max_Chain_Length loop
  346.             if F (I) /= 0 then
  347.                Write_Str ("Number of hash chains of length ");
  348.  
  349.                if I < 10 then
  350.                   Write_Char (' ');
  351.                end if;
  352.  
  353.                Write_Int (I);
  354.  
  355.                if I = Max_Chain_Length then
  356.                   Write_Str (" or greater");
  357.                end if;
  358.  
  359.                Write_Str (" = ");
  360.                Write_Int (F (I));
  361.                Write_Eol;
  362.  
  363.                if I /= 0 then
  364.                   Nsyms := Nsyms + F (I);
  365.                   Probes := Probes + F (I) * (1 + I) * 100;
  366.                end if;
  367.             end if;
  368.          end loop;
  369.  
  370.          Write_Eol;
  371.          Write_Str ("Average number of probes for lookup = ");
  372.          Probes := Probes / Nsyms;
  373.          Write_Int (Probes / 200);
  374.          Write_Char ('.');
  375.          Probes := (Probes mod 200) / 2;
  376.          Write_Char (Character'Val (48 + Probes / 10));
  377.          Write_Char (Character'Val (48 + Probes mod 10));
  378.          Write_Eol;
  379.          Write_Eol;
  380.       end if;
  381.    end Finalize;
  382.  
  383.    ---------------------
  384.    -- Get_Name_String --
  385.    ---------------------
  386.  
  387.    procedure Get_Name_String (Id : Name_Id) is
  388.       S : Int;
  389.  
  390.    begin
  391.       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
  392.  
  393.       S := Name_Entries.Table (Id).Name_Chars_Index;
  394.       Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
  395.  
  396.       for I in 1 .. Name_Len loop
  397.          Name_Buffer (I) := Name_Chars.Table (S + Int (I));
  398.       end loop;
  399.    end Get_Name_String;
  400.  
  401.    -----------------------------
  402.    -- Get_Decoded_Name_String --
  403.    -----------------------------
  404.  
  405.    procedure Get_Decoded_Name_String (Id : Name_Id) is
  406.    begin
  407.       Get_Name_String (Id);
  408.  
  409.       --  Case of operator name
  410.  
  411.       if Name_Buffer (1) = 'O' then
  412.          Name_Buffer (1) := '"';
  413.  
  414.          declare
  415.             --  This table maps the 2nd and 3rd characters of the name into
  416.             --  the required output. Two blanks means leave the name alone
  417.  
  418.             Map : constant String :=
  419.                "ab  " &                   --  Oabs         => "abs"
  420.                "ad+ " &                   --  Oadd         => "+"
  421.                "an  " &                   --  Oand         => "and"
  422.                "co& " &                   --  Oconcat      => "&"
  423.                "di/ " &                   --  Odivide      => "/"
  424.                "eq= " &                   --  Oeq          => "="
  425.                "ex**" &                   --  Oexpon       => "**"
  426.                "gt> " &                   --  Ogt          => ">"
  427.                "ge>=" &                   --  Oge          => ">="
  428.                "le<=" &                   --  Ole          => "<="
  429.                "lt< " &                   --  Olt          => "<"
  430.                "mo  " &                   --  Omod         => "mod"
  431.                "mu* " &                   --  Omutliply    => "*"
  432.                "ne/=" &                   --  One          => "/="
  433.                "no  " &                   --  Onot         => "not"
  434.                "or  " &                   --  Oor          => "or"
  435.                "re  " &                   --  Orem         => "rem"
  436.                "su- " &                   --  Osubtract    => "-"
  437.                "xo  ";                    --  Oxor         => "xor"
  438.  
  439.             J : Integer;
  440.  
  441.          begin
  442.             J := Map'First;
  443.  
  444.             --  Note that this loop must terminate, if not we have some kind
  445.             --  of internal error, and a constraint error will be raised.
  446.  
  447.             loop
  448.                exit when Name_Buffer (2) = Map (J)
  449.                  and then Name_Buffer (3) = Map (J + 1);
  450.                J := J + 4;
  451.             end loop;
  452.  
  453.             --  Special operator name
  454.  
  455.             if Map (J + 2) /= ' ' then
  456.                Name_Buffer (2) := Map (J + 2);
  457.                Name_Len := 3;
  458.  
  459.                if Map (J + 3) /= ' ' then
  460.                   Name_Buffer (3) := Map (J + 3);
  461.                   Name_Len := 4;
  462.                end if;
  463.  
  464.                Name_Buffer (Name_Len) := '"';
  465.                return;
  466.  
  467.             --  For other operator names, leave them in lower case,
  468.             --  surrounded by apostrophes
  469.  
  470.             else
  471.                Name_Len := Name_Len + 1;
  472.                Name_Buffer (Name_Len) := '"';
  473.                return;
  474.             end if;
  475.          end;
  476.       end if;
  477.  
  478.       --  For character literals, put apostrophes around, and then fall into
  479.       --  the remaining circuit for possible decoding of Uhh/Whhhh sequence.
  480.  
  481.       if Name_Buffer (1) = 'Q' then
  482.          Name_Buffer (1) := ''';
  483.          Name_Len := Name_Len + 1;
  484.          Name_Buffer (Name_Len) := ''';
  485.       end if;
  486.  
  487.       --  Only remaining task is to decode Uhh and Whhhh sequences. First
  488.       --  a quick check to see if there are any such sequences in the name
  489.  
  490.       for J in 1 .. Name_Len loop
  491.          if Name_Buffer (J) = 'U' or else Name_Buffer (J) = 'W' then
  492.             goto Do_Decode;
  493.          end if;
  494.       end loop;
  495.  
  496.       return;
  497.  
  498.       --  Here we have to decode one or more Uhh or Whhhh sequences
  499.  
  500.       <<Do_Decode>> declare
  501.          New_Len : Natural;
  502.          Old     : Positive;
  503.          New_Buf : String (1 .. System.Parameters.Max_Name_Length);
  504.  
  505.          function Hex (N : Natural) return Natural;
  506.          --  Scans past N digits using Old pointer and returns hex value
  507.  
  508.          function Hex (N : Natural) return Natural is
  509.             T : Natural := 0;
  510.             C : Character;
  511.  
  512.          begin
  513.             for J in 1 .. N loop
  514.                C := Name_Buffer (Old);
  515.                Old := Old + 1;
  516.  
  517.                pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
  518.  
  519.                if C <= '9' then
  520.                   T := 16 * T + Character'Pos (C) - Character'Pos ('0');
  521.                else -- C in 'a' .. 'f'
  522.                   T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
  523.                end if;
  524.             end loop;
  525.  
  526.             return T;
  527.          end Hex;
  528.  
  529.       begin
  530.          New_Len := 0;
  531.          Old := 1;
  532.  
  533.          while Old <= Name_Len loop
  534.             if Name_Buffer (Old) = 'U' then
  535.                Old := Old + 1;
  536.                New_Len := New_Len + 1;
  537.                New_Buf (New_Len) := Character'Val (Hex (2));
  538.  
  539.             elsif Name_Buffer (Old) = 'W' then
  540.                Old := Old + 1;
  541.                Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
  542.  
  543.             else
  544.                New_Len := New_Len + 1;
  545.                New_Buf (New_Len) := Name_Buffer (Old);
  546.                Old := Old + 1;
  547.             end if;
  548.          end loop;
  549.  
  550.          Name_Len := New_Len;
  551.          Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
  552.       end;
  553.    end Get_Decoded_Name_String;
  554.  
  555.    -------------------------
  556.    -- Get_Name_Table_Byte --
  557.    -------------------------
  558.  
  559.    function Get_Name_Table_Byte (Id : Name_Id) return Byte is
  560.    begin
  561.       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
  562.       return Name_Entries.Table (Id).Byte_Info;
  563.    end Get_Name_Table_Byte;
  564.  
  565.    -------------------------
  566.    -- Get_Name_Table_Info --
  567.    -------------------------
  568.  
  569.    function Get_Name_Table_Info (Id : Name_Id) return Int is
  570.    begin
  571.       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
  572.       return Name_Entries.Table (Id).Int_Info;
  573.    end Get_Name_Table_Info;
  574.  
  575.    ----------------
  576.    -- Initialize --
  577.    ----------------
  578.  
  579.    procedure Initialize is
  580.  
  581.    begin
  582.       Name_Chars.Init;
  583.       Name_Entries.Init;
  584.  
  585.       --  Initialize entries for one character names
  586.  
  587.       for C in Character loop
  588.          Name_Entries.Increment_Last;
  589.          Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
  590.            Name_Chars.Last;
  591.          Name_Entries.Table (Name_Entries.Last).Name_Len  := 1;
  592.          Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
  593.          Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
  594.          Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
  595.          Name_Chars.Increment_Last;
  596.          Name_Chars.Table (Name_Chars.Last) := C;
  597.          Name_Chars.Increment_Last;
  598.          Name_Chars.Table (Name_Chars.Last) := Ascii.NUL;
  599.       end loop;
  600.  
  601.       --  Clear hash table
  602.  
  603.       for J in Hash_Index_Type loop
  604.          Hash_Table (J) := No_Name;
  605.       end loop;
  606.    end Initialize;
  607.  
  608.    ----------------------
  609.    -- Is_Internal_Name --
  610.    ----------------------
  611.  
  612.    function Is_Internal_Name (Id : Name_Id) return Boolean is
  613.    begin
  614.       Get_Name_String (Id);
  615.  
  616.       for J in 1 .. Name_Len loop
  617.          if Is_OK_Internal_Letter (Name_Buffer (J)) then
  618.             return True;
  619.  
  620.          elsif Name_Buffer (J) = '_'
  621.            and then (J = 1
  622.                       or else J = Name_Len
  623.                       or else Name_Buffer (J + 1) = '_')
  624.          then
  625.             return True;
  626.          end if;
  627.       end loop;
  628.  
  629.       return False;
  630.    end Is_Internal_Name;
  631.  
  632.    ---------------------------
  633.    -- Is_OK_Internal_Letter --
  634.    ---------------------------
  635.  
  636.    function Is_OK_Internal_Letter (C : Character) return Boolean is
  637.    begin
  638.       return C in 'A' .. 'Z'
  639.         and then C /= 'O'
  640.         and then C /= 'Q'
  641.         and then C /= 'U'
  642.         and then C /= 'W';
  643.    end Is_OK_Internal_Letter;
  644.  
  645.    --------------------
  646.    -- Length_Of_Name --
  647.    --------------------
  648.  
  649.    function Length_Of_Name (Id : Name_Id) return Nat is
  650.    begin
  651.       return Int (Name_Entries.Table (Id).Name_Len);
  652.    end Length_Of_Name;
  653.  
  654.    ------------------------
  655.    -- Name_Chars_Address --
  656.    ------------------------
  657.  
  658.    function Name_Chars_Address return System.Address is
  659.    begin
  660.       return Name_Chars.Table (0)'Address;
  661.    end Name_Chars_Address;
  662.  
  663.    ----------------
  664.    -- Name_Enter --
  665.    ----------------
  666.  
  667.    function Name_Enter return Name_Id is
  668.    begin
  669.  
  670.       Name_Entries.Increment_Last;
  671.       Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
  672.         Name_Chars.Last;
  673.       Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
  674.       Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
  675.       Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
  676.       Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
  677.  
  678.       --  Set corresponding string entry in the Name_Chars table
  679.  
  680.       for J in 1 .. Name_Len loop
  681.          Name_Chars.Increment_Last;
  682.          Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
  683.       end loop;
  684.  
  685.       Name_Chars.Increment_Last;
  686.       Name_Chars.Table (Name_Chars.Last) := Ascii.NUL;
  687.  
  688.       return Name_Entries.Last;
  689.    end Name_Enter;
  690.  
  691.    --------------------------
  692.    -- Name_Entries_Address --
  693.    --------------------------
  694.  
  695.    function Name_Entries_Address return System.Address is
  696.    begin
  697.       return Name_Entries.Table (First_Name_Id)'Address;
  698.    end Name_Entries_Address;
  699.  
  700.    ------------------------
  701.    -- Name_Entries_Count --
  702.    ------------------------
  703.  
  704.    function Name_Entries_Count return Nat is
  705.    begin
  706.       return Int (Name_Entries.Last - Name_Entries.First + 1);
  707.    end Name_Entries_Count;
  708.  
  709.    ---------------
  710.    -- Name_Find --
  711.    ---------------
  712.  
  713.    function Name_Find return Name_Id is
  714.       New_Id : Name_Id;
  715.       --  Id of entry in hash search, and value to be returned
  716.  
  717.       S : Int;
  718.       --  Pointer into string table
  719.  
  720.       Hash_Index : Hash_Index_Type;
  721.       --  Computed hash index
  722.  
  723.    begin
  724.       --  Quick handling for one character names
  725.  
  726.       if Name_Len = 1 then
  727.          return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
  728.  
  729.       --  Otherwise search hash table for existing matching entry
  730.  
  731.       else
  732.          Hash_Index := Namet.Hash;
  733.          New_Id := Hash_Table (Hash_Index);
  734.  
  735.          if New_Id = No_Name then
  736.             Hash_Table (Hash_Index) := Name_Entries.Last + 1;
  737.  
  738.          else
  739.             Search : loop
  740.                if Name_Len /=
  741.                  Integer (Name_Entries.Table (New_Id).Name_Len)
  742.                then
  743.                   goto No_Match;
  744.                end if;
  745.  
  746.                S := Name_Entries.Table (New_Id).Name_Chars_Index;
  747.  
  748.                for I in 1 .. Name_Len loop
  749.                   if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then
  750.                      goto No_Match;
  751.                   end if;
  752.                end loop;
  753.  
  754.                return New_Id;
  755.  
  756.                --  Current entry in hash chain does not match
  757.  
  758.                <<No_Match>>
  759.                   if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
  760.                      New_Id := Name_Entries.Table (New_Id).Hash_Link;
  761.                   else
  762.                      Name_Entries.Table (New_Id).Hash_Link :=
  763.                        Name_Entries.Last + 1;
  764.                      exit Search;
  765.                   end if;
  766.  
  767.             end loop Search;
  768.          end if;
  769.  
  770.          --  We fall through here only if a matching entry was not found in the
  771.          --  hash table. We now create a new entry in the names table. The hash
  772.          --  link pointing to the new entry (Name_Entries.Last+1) has been set.
  773.  
  774.          Name_Entries.Increment_Last;
  775.          Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
  776.            Name_Chars.Last;
  777.          Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
  778.          Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
  779.          Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
  780.          Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
  781.  
  782.          --  Set corresponding string entry in the Name_Chars table
  783.  
  784.          for I in 1 .. Name_Len loop
  785.             Name_Chars.Increment_Last;
  786.             Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
  787.          end loop;
  788.  
  789.          Name_Chars.Increment_Last;
  790.          Name_Chars.Table (Name_Chars.Last) := Ascii.NUL;
  791.  
  792.          return Name_Entries.Last;
  793.       end if;
  794.    end Name_Find;
  795.  
  796.    ----------------------
  797.    -- Reset_Name_Table --
  798.    ----------------------
  799.  
  800.    procedure Reset_Name_Table is
  801.    begin
  802.       for J in First_Name_Id .. Name_Entries.Last loop
  803.          Name_Entries.Table (J).Int_Info  := 0;
  804.          Name_Entries.Table (J).Byte_Info := 0;
  805.       end loop;
  806.    end Reset_Name_Table;
  807.  
  808.    --------------------------------
  809.    -- Set_Character_Literal_Name --
  810.    --------------------------------
  811.  
  812.    procedure Set_Character_Literal_Name (C : Char_Code) is
  813.    begin
  814.       Name_Buffer (1) := 'Q';
  815.       Name_Len := 1;
  816.       Store_Encoded_Character (C);
  817.    end Set_Character_Literal_Name;
  818.  
  819.    -------------------------
  820.    -- Set_Name_Table_Info --
  821.    -------------------------
  822.  
  823.    procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
  824.    begin
  825.       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
  826.       Name_Entries.Table (Id).Int_Info := Val;
  827.    end Set_Name_Table_Info;
  828.  
  829.    -------------------------
  830.    -- Set_Name_Table_Byte --
  831.    -------------------------
  832.  
  833.    procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
  834.    begin
  835.       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
  836.       Name_Entries.Table (Id).Byte_Info := Val;
  837.    end Set_Name_Table_Byte;
  838.  
  839.    -----------------------------
  840.    -- Store_Encoded_Character --
  841.    -----------------------------
  842.  
  843.    procedure Store_Encoded_Character (C : Char_Code) is
  844.  
  845.       procedure Set_Hex_Chars (N : Natural);
  846.       --  Stores given value, which is in the range 0 .. 255, as two hex
  847.       --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len
  848.  
  849.       procedure Set_Hex_Chars (N : Natural) is
  850.          Hexd : constant String := "0123456789abcdef";
  851.  
  852.       begin
  853.          Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
  854.          Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
  855.          Name_Len := Name_Len + 2;
  856.       end Set_Hex_Chars;
  857.  
  858.    begin
  859.       Name_Len := Name_Len + 1;
  860.  
  861.       if In_Character_Range (C) then
  862.          declare
  863.             CC : constant Character := Get_Character (C);
  864.  
  865.          begin
  866.             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
  867.                Name_Buffer (Name_Len) := CC;
  868.  
  869.             else
  870.                Name_Buffer (Name_Len) := 'U';
  871.                Set_Hex_Chars (Natural (C));
  872.             end if;
  873.          end;
  874.  
  875.       else
  876.          Name_Buffer (Name_Len) := 'W';
  877.          Set_Hex_Chars (Natural (C) / 256);
  878.          Set_Hex_Chars (Natural (C) mod 256);
  879.       end if;
  880.  
  881.    end Store_Encoded_Character;
  882.  
  883.    ---------------
  884.    -- Tree_Read --
  885.    ---------------
  886.  
  887.    procedure Tree_Read is
  888.    begin
  889.       Name_Chars.Tree_Read;
  890.       Name_Entries.Tree_Read;
  891.  
  892.       Tree_Read_Data (Hash_Table'Address,
  893.                       Hash_Table'Length * (Name_Id'Size / Storage_Unit));
  894.    end Tree_Read;
  895.  
  896.    ----------------
  897.    -- Tree_Write --
  898.    ----------------
  899.  
  900.    procedure Tree_Write is
  901.    begin
  902.       Name_Chars.Tree_Write;
  903.       Name_Entries.Tree_Write;
  904.  
  905.       Tree_Write_Data
  906.         (Hash_Table'Address,
  907.          Hash_Table'Length * (Name_Id'Size / Storage_Unit));
  908.    end Tree_Write;
  909.  
  910.    -----------------
  911.    --  Write_Name --
  912.    -----------------
  913.  
  914.    procedure Write_Name (Id : Name_Id) is
  915.    begin
  916.       if Id >= First_Name_Id then
  917.          Get_Name_String (Id);
  918.          Write_Str (Name_Buffer (1 .. Name_Len));
  919.       end if;
  920.    end Write_Name;
  921.  
  922.    ------------------------
  923.    -- Write_Name_Decoded --
  924.    ------------------------
  925.  
  926.    procedure Write_Name_Decoded (Id : Name_Id) is
  927.    begin
  928.       if Id >= First_Name_Id then
  929.          Get_Decoded_Name_String (Id);
  930.          Write_Str (Name_Buffer (1 .. Name_Len));
  931.       end if;
  932.    end Write_Name_Decoded;
  933.  
  934. end Namet;
  935.