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

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [ada/] [g-spitbo.adb] - Blame information for rev 384

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                         G N A T . S P I T B O L                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1998-2009, AdaCore                     --
--                                                                          --
-- 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 2,  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Ada.Strings;               use Ada.Strings;
with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
 
with GNAT.Debug_Utilities;      use GNAT.Debug_Utilities;
with GNAT.IO;                   use GNAT.IO;
 
with System.String_Hash;
 
with Ada.Unchecked_Deallocation;
 
package body GNAT.Spitbol is
 
   ---------
   -- "&" --
   ---------
 
   function "&" (Num : Integer; Str : String)  return String is
   begin
      return S (Num) & Str;
   end "&";
 
   function "&" (Str : String;  Num : Integer) return String is
   begin
      return Str & S (Num);
   end "&";
 
   function "&" (Num : Integer; Str : VString) return VString is
   begin
      return S (Num) & Str;
   end "&";
 
   function "&" (Str : VString; Num : Integer) return VString is
   begin
      return Str & S (Num);
   end "&";
 
   ----------
   -- Char --
   ----------
 
   function Char (Num : Natural) return Character is
   begin
      return Character'Val (Num);
   end Char;
 
   ----------
   -- Lpad --
   ----------
 
   function Lpad
     (Str : VString;
      Len : Natural;
      Pad : Character := ' ') return VString
   is
   begin
      if Length (Str) >= Len then
         return Str;
      else
         return Tail (Str, Len, Pad);
      end if;
   end Lpad;
 
   function Lpad
     (Str : String;
      Len : Natural;
      Pad : Character := ' ') return VString
   is
   begin
      if Str'Length >= Len then
         return V (Str);
 
      else
         declare
            R : String (1 .. Len);
 
         begin
            for J in 1 .. Len - Str'Length loop
               R (J) := Pad;
            end loop;
 
            R (Len - Str'Length + 1 .. Len) := Str;
            return V (R);
         end;
      end if;
   end Lpad;
 
   procedure Lpad
     (Str  : in out VString;
      Len  : Natural;
      Pad  : Character := ' ')
   is
   begin
      if Length (Str) >= Len then
         return;
      else
         Tail (Str, Len, Pad);
      end if;
   end Lpad;
 
   -------
   -- N --
   -------
 
   function N (Str : VString) return Integer is
      S : String_Access;
      L : Natural;
   begin
      Get_String (Str, S, L);
      return Integer'Value (S (1 .. L));
   end N;
 
   --------------------
   -- Reverse_String --
   --------------------
 
   function Reverse_String (Str : VString) return VString is
      S : String_Access;
      L : Natural;
 
   begin
      Get_String (Str, S, L);
 
      declare
         Result : String (1 .. L);
 
      begin
         for J in 1 .. L loop
            Result (J) := S (L + 1 - J);
         end loop;
 
         return V (Result);
      end;
   end Reverse_String;
 
   function Reverse_String (Str : String) return VString is
      Result : String (1 .. Str'Length);
 
   begin
      for J in 1 .. Str'Length loop
         Result (J) := Str (Str'Last + 1 - J);
      end loop;
 
      return V (Result);
   end Reverse_String;
 
   procedure Reverse_String (Str : in out VString) is
      S : String_Access;
      L : Natural;
 
   begin
      Get_String (Str, S, L);
 
      declare
         Result : String (1 .. L);
 
      begin
         for J in 1 .. L loop
            Result (J) := S (L + 1 - J);
         end loop;
 
         Set_String (Str, Result);
      end;
   end Reverse_String;
 
   ----------
   -- Rpad --
   ----------
 
   function Rpad
     (Str : VString;
      Len : Natural;
      Pad : Character := ' ') return VString
   is
   begin
      if Length (Str) >= Len then
         return Str;
      else
         return Head (Str, Len, Pad);
      end if;
   end Rpad;
 
   function Rpad
     (Str : String;
      Len : Natural;
      Pad : Character := ' ') return VString
   is
   begin
      if Str'Length >= Len then
         return V (Str);
 
      else
         declare
            R : String (1 .. Len);
 
         begin
            for J in Str'Length + 1 .. Len loop
               R (J) := Pad;
            end loop;
 
            R (1 .. Str'Length) := Str;
            return V (R);
         end;
      end if;
   end Rpad;
 
   procedure Rpad
     (Str  : in out VString;
      Len  : Natural;
      Pad  : Character := ' ')
   is
   begin
      if Length (Str) >= Len then
         return;
 
      else
         Head (Str, Len, Pad);
      end if;
   end Rpad;
 
   -------
   -- S --
   -------
 
   function S (Num : Integer) return String is
      Buf : String (1 .. 30);
      Ptr : Natural := Buf'Last + 1;
      Val : Natural := abs (Num);
 
   begin
      loop
         Ptr := Ptr - 1;
         Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
         Val := Val / 10;
         exit when Val = 0;
      end loop;
 
      if Num < 0 then
         Ptr := Ptr - 1;
         Buf (Ptr) := '-';
      end if;
 
      return Buf (Ptr .. Buf'Last);
   end S;
 
   ------------
   -- Substr --
   ------------
 
   function Substr
     (Str   : VString;
      Start : Positive;
      Len   : Natural) return VString
   is
      S : String_Access;
      L : Natural;
 
   begin
      Get_String (Str, S, L);
 
      if Start > L then
         raise Index_Error;
      elsif Start + Len - 1 > L then
         raise Length_Error;
      else
         return V (S (Start .. Start + Len - 1));
      end if;
   end Substr;
 
   function Substr
     (Str   : String;
      Start : Positive;
      Len   : Natural) return VString
   is
   begin
      if Start > Str'Length then
         raise Index_Error;
      elsif Start + Len > Str'Length then
         raise Length_Error;
      else
         return
           V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
      end if;
   end Substr;
 
   -----------
   -- Table --
   -----------
 
   package body Table is
 
      procedure Free is new
        Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
 
      -----------------------
      -- Local Subprograms --
      -----------------------
 
      function Hash is new System.String_Hash.Hash
        (Character, String, Unsigned_32);
 
      ------------
      -- Adjust --
      ------------
 
      procedure Adjust (Object : in out Table) is
         Ptr1 : Hash_Element_Ptr;
         Ptr2 : Hash_Element_Ptr;
 
      begin
         for J in Object.Elmts'Range loop
            Ptr1 := Object.Elmts (J)'Unrestricted_Access;
 
            if Ptr1.Name /= null then
               loop
                  Ptr1.Name := new String'(Ptr1.Name.all);
                  exit when Ptr1.Next = null;
                  Ptr2 := Ptr1.Next;
                  Ptr1.Next := new Hash_Element'(Ptr2.all);
                  Ptr1 := Ptr1.Next;
               end loop;
            end if;
         end loop;
      end Adjust;
 
      -----------
      -- Clear --
      -----------
 
      procedure Clear (T : in out Table) is
         Ptr1 : Hash_Element_Ptr;
         Ptr2 : Hash_Element_Ptr;
 
      begin
         for J in T.Elmts'Range loop
            if T.Elmts (J).Name /= null then
               Free (T.Elmts (J).Name);
               T.Elmts (J).Value := Null_Value;
 
               Ptr1 := T.Elmts (J).Next;
               T.Elmts (J).Next := null;
 
               while Ptr1 /= null loop
                  Ptr2 := Ptr1.Next;
                  Free (Ptr1.Name);
                  Free (Ptr1);
                  Ptr1 := Ptr2;
               end loop;
            end if;
         end loop;
      end Clear;
 
      ----------------------
      -- Convert_To_Array --
      ----------------------
 
      function Convert_To_Array (T : Table) return Table_Array is
         Num_Elmts : Natural := 0;
         Elmt      : Hash_Element_Ptr;
 
      begin
         for J in T.Elmts'Range loop
            Elmt := T.Elmts (J)'Unrestricted_Access;
 
            if Elmt.Name /= null then
               loop
                  Num_Elmts := Num_Elmts + 1;
                  Elmt := Elmt.Next;
                  exit when Elmt = null;
               end loop;
            end if;
         end loop;
 
         declare
            TA  : Table_Array (1 .. Num_Elmts);
            P   : Natural := 1;
 
         begin
            for J in T.Elmts'Range loop
               Elmt := T.Elmts (J)'Unrestricted_Access;
 
               if Elmt.Name /= null then
                  loop
                     Set_String (TA (P).Name, Elmt.Name.all);
                     TA (P).Value := Elmt.Value;
                     P := P + 1;
                     Elmt := Elmt.Next;
                     exit when Elmt = null;
                  end loop;
               end if;
            end loop;
 
            return TA;
         end;
      end Convert_To_Array;
 
      ----------
      -- Copy --
      ----------
 
      procedure Copy (From : Table; To : in out Table) is
         Elmt : Hash_Element_Ptr;
 
      begin
         Clear (To);
 
         for J in From.Elmts'Range loop
            Elmt := From.Elmts (J)'Unrestricted_Access;
            if Elmt.Name /= null then
               loop
                  Set (To, Elmt.Name.all, Elmt.Value);
                  Elmt := Elmt.Next;
                  exit when Elmt = null;
               end loop;
            end if;
         end loop;
      end Copy;
 
      ------------
      -- Delete --
      ------------
 
      procedure Delete (T : in out Table; Name : Character) is
      begin
         Delete (T, String'(1 => Name));
      end Delete;
 
      procedure Delete (T : in out Table; Name  : VString) is
         S : String_Access;
         L : Natural;
      begin
         Get_String (Name, S, L);
         Delete (T, S (1 .. L));
      end Delete;
 
      procedure Delete (T : in out Table; Name  : String) is
         Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
         Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
         Next : Hash_Element_Ptr;
 
      begin
         if Elmt.Name = null then
            null;
 
         elsif Elmt.Name.all = Name then
            Free (Elmt.Name);
 
            if Elmt.Next = null then
               Elmt.Value := Null_Value;
               return;
 
            else
               Next := Elmt.Next;
               Elmt.Name  := Next.Name;
               Elmt.Value := Next.Value;
               Elmt.Next  := Next.Next;
               Free (Next);
               return;
            end if;
 
         else
            loop
               Next := Elmt.Next;
 
               if Next = null then
                  return;
 
               elsif Next.Name.all = Name then
                  Free (Next.Name);
                  Elmt.Next := Next.Next;
                  Free (Next);
                  return;
 
               else
                  Elmt := Next;
               end if;
            end loop;
         end if;
      end Delete;
 
      ----------
      -- Dump --
      ----------
 
      procedure Dump (T : Table; Str : String := "Table") is
         Num_Elmts : Natural := 0;
         Elmt      : Hash_Element_Ptr;
 
      begin
         for J in T.Elmts'Range loop
            Elmt := T.Elmts (J)'Unrestricted_Access;
 
            if Elmt.Name /= null then
               loop
                  Num_Elmts := Num_Elmts + 1;
                  Put_Line
                    (Str & '<' & Image (Elmt.Name.all) & "> = " &
                     Img (Elmt.Value));
                  Elmt := Elmt.Next;
                  exit when Elmt = null;
               end loop;
            end if;
         end loop;
 
         if Num_Elmts = 0 then
            Put_Line (Str & " is empty");
         end if;
      end Dump;
 
      procedure Dump (T : Table_Array; Str : String := "Table_Array") is
      begin
         if T'Length = 0 then
            Put_Line (Str & " is empty");
 
         else
            for J in T'Range loop
               Put_Line
                 (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
                  Img (T (J).Value));
            end loop;
         end if;
      end Dump;
 
      --------------
      -- Finalize --
      --------------
 
      procedure Finalize (Object : in out Table) is
         Ptr1 : Hash_Element_Ptr;
         Ptr2 : Hash_Element_Ptr;
 
      begin
         for J in Object.Elmts'Range loop
            Ptr1 := Object.Elmts (J).Next;
            Free (Object.Elmts (J).Name);
            while Ptr1 /= null loop
               Ptr2 := Ptr1.Next;
               Free (Ptr1.Name);
               Free (Ptr1);
               Ptr1 := Ptr2;
            end loop;
         end loop;
      end Finalize;
 
      ---------
      -- Get --
      ---------
 
      function Get (T : Table; Name : Character) return Value_Type is
      begin
         return Get (T, String'(1 => Name));
      end Get;
 
      function Get (T : Table; Name : VString) return Value_Type is
         S : String_Access;
         L : Natural;
      begin
         Get_String (Name, S, L);
         return Get (T, S (1 .. L));
      end Get;
 
      function Get (T : Table; Name : String) return Value_Type is
         Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
         Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 
      begin
         if Elmt.Name = null then
            return Null_Value;
 
         else
            loop
               if Name = Elmt.Name.all then
                  return Elmt.Value;
 
               else
                  Elmt := Elmt.Next;
 
                  if Elmt = null then
                     return Null_Value;
                  end if;
               end if;
            end loop;
         end if;
      end Get;
 
      -------------
      -- Present --
      -------------
 
      function Present (T : Table; Name : Character) return Boolean is
      begin
         return Present (T, String'(1 => Name));
      end Present;
 
      function Present (T : Table; Name : VString) return Boolean is
         S : String_Access;
         L : Natural;
      begin
         Get_String (Name, S, L);
         return Present (T, S (1 .. L));
      end Present;
 
      function Present (T : Table; Name : String) return Boolean is
         Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
         Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 
      begin
         if Elmt.Name = null then
            return False;
 
         else
            loop
               if Name = Elmt.Name.all then
                  return True;
 
               else
                  Elmt := Elmt.Next;
 
                  if Elmt = null then
                     return False;
                  end if;
               end if;
            end loop;
         end if;
      end Present;
 
      ---------
      -- Set --
      ---------
 
      procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
         S : String_Access;
         L : Natural;
      begin
         Get_String (Name, S, L);
         Set (T, S (1 .. L), Value);
      end Set;
 
      procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
      begin
         Set (T, String'(1 => Name), Value);
      end Set;
 
      procedure Set
        (T     : in out Table;
         Name  : String;
         Value : Value_Type)
      is
      begin
         if Value = Null_Value then
            Delete (T, Name);
 
         else
            declare
               Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
               Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 
               subtype String1 is String (1 .. Name'Length);
 
            begin
               if Elmt.Name = null then
                  Elmt.Name  := new String'(String1 (Name));
                  Elmt.Value := Value;
                  return;
 
               else
                  loop
                     if Name = Elmt.Name.all then
                        Elmt.Value := Value;
                        return;
 
                     elsif Elmt.Next = null then
                        Elmt.Next := new Hash_Element'(
                                       Name  => new String'(String1 (Name)),
                                       Value => Value,
                                       Next  => null);
                        return;
 
                     else
                        Elmt := Elmt.Next;
                     end if;
                  end loop;
               end if;
            end;
         end if;
      end Set;
   end Table;
 
   ----------
   -- Trim --
   ----------
 
   function Trim (Str : VString) return VString is
   begin
      return Trim (Str, Right);
   end Trim;
 
   function Trim (Str : String) return VString is
   begin
      for J in reverse Str'Range loop
         if Str (J) /= ' ' then
            return V (Str (Str'First .. J));
         end if;
      end loop;
 
      return Nul;
   end Trim;
 
   procedure Trim (Str : in out VString) is
   begin
      Trim (Str, Right);
   end Trim;
 
   -------
   -- V --
   -------
 
   function V (Num : Integer) return VString is
      Buf : String (1 .. 30);
      Ptr : Natural := Buf'Last + 1;
      Val : Natural := abs (Num);
 
   begin
      loop
         Ptr := Ptr - 1;
         Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
         Val := Val / 10;
         exit when Val = 0;
      end loop;
 
      if Num < 0 then
         Ptr := Ptr - 1;
         Buf (Ptr) := '-';
      end if;
 
      return V (Buf (Ptr .. Buf'Last));
   end V;
 
end GNAT.Spitbol;

Browse

Tools

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [ada/] [g-spitbo.adb] - Blame information for rev 384

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT LIBRARY COMPONENTS --`
4			`-- --`
5			`-- G N A T . S P I T B O L --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1998-2009, AdaCore --`
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 2, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
19			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, USA. --`
21			`-- --`
22			`-- As a special exception, if other files instantiate generics from this --`
23			`-- unit, or you link this unit with other files to produce an executable, --`
24			`-- this unit does not by itself cause the resulting executable to be --`
25			`-- covered by the GNU General Public License. This exception does not --`
26			`-- however invalidate any other reasons why the executable file might be --`
27			`-- covered by the GNU Public License. --`
28			`-- --`
29			`-- GNAT was originally developed by the GNAT team at New York University. --`
30			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
31			`-- --`
32			`------------------------------------------------------------------------------`
33
34			`with Ada.Strings; use Ada.Strings;`
35			`with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;`
36
37			`with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;`
38			`with GNAT.IO; use GNAT.IO;`
39
40			`with System.String_Hash;`
41
42			`with Ada.Unchecked_Deallocation;`
43
44			`package body GNAT.Spitbol is`
45
46			`---------`
47			`-- "&" --`
48			`---------`
49
50			`function "&" (Num : Integer; Str : String) return String is`
51			`begin`
52			`return S (Num) & Str;`
53			`end "&";`
54
55			`function "&" (Str : String; Num : Integer) return String is`
56			`begin`
57			`return Str & S (Num);`
58			`end "&";`
59
60			`function "&" (Num : Integer; Str : VString) return VString is`
61			`begin`
62			`return S (Num) & Str;`
63			`end "&";`
64
65			`function "&" (Str : VString; Num : Integer) return VString is`
66			`begin`
67			`return Str & S (Num);`
68			`end "&";`
69
70			`----------`
71			`-- Char --`
72			`----------`
73
74			`function Char (Num : Natural) return Character is`
75			`begin`
76			`return Character'Val (Num);`
77			`end Char;`
78
79			`----------`
80			`-- Lpad --`
81			`----------`
82
83			`function Lpad`
84			`(Str : VString;`
85			`Len : Natural;`
86			`Pad : Character := ' ') return VString`
87			`is`
88			`begin`
89			`if Length (Str) >= Len then`
90			`return Str;`
91			`else`
92			`return Tail (Str, Len, Pad);`
93			`end if;`
94			`end Lpad;`
95
96			`function Lpad`
97			`(Str : String;`
98			`Len : Natural;`
99			`Pad : Character := ' ') return VString`
100			`is`
101			`begin`
102			`if Str'Length >= Len then`
103			`return V (Str);`
104
105			`else`
106			`declare`
107			`R : String (1 .. Len);`
108
109			`begin`
110			`for J in 1 .. Len - Str'Length loop`
111			`R (J) := Pad;`
112			`end loop;`
113
114			`R (Len - Str'Length + 1 .. Len) := Str;`
115			`return V (R);`
116			`end;`
117			`end if;`
118			`end Lpad;`
119
120			`procedure Lpad`
121			`(Str : in out VString;`
122			`Len : Natural;`
123			`Pad : Character := ' ')`
124			`is`
125			`begin`
126			`if Length (Str) >= Len then`
127			`return;`
128			`else`
129			`Tail (Str, Len, Pad);`
130			`end if;`
131			`end Lpad;`
132
133			`-------`
134			`-- N --`
135			`-------`
136
137			`function N (Str : VString) return Integer is`
138			`S : String_Access;`
139			`L : Natural;`
140			`begin`
141			`Get_String (Str, S, L);`
142			`return Integer'Value (S (1 .. L));`
143			`end N;`
144
145			`--------------------`
146			`-- Reverse_String --`
147			`--------------------`
148
149			`function Reverse_String (Str : VString) return VString is`
150			`S : String_Access;`
151			`L : Natural;`
152
153			`begin`
154			`Get_String (Str, S, L);`
155
156			`declare`
157			`Result : String (1 .. L);`
158
159			`begin`
160			`for J in 1 .. L loop`
161			`Result (J) := S (L + 1 - J);`
162			`end loop;`
163
164			`return V (Result);`
165			`end;`
166			`end Reverse_String;`
167
168			`function Reverse_String (Str : String) return VString is`
169			`Result : String (1 .. Str'Length);`
170
171			`begin`
172			`for J in 1 .. Str'Length loop`
173			`Result (J) := Str (Str'Last + 1 - J);`
174			`end loop;`
175
176			`return V (Result);`
177			`end Reverse_String;`
178
179			`procedure Reverse_String (Str : in out VString) is`
180			`S : String_Access;`
181			`L : Natural;`
182
183			`begin`
184			`Get_String (Str, S, L);`
185
186			`declare`
187			`Result : String (1 .. L);`
188
189			`begin`
190			`for J in 1 .. L loop`
191			`Result (J) := S (L + 1 - J);`
192			`end loop;`
193
194			`Set_String (Str, Result);`
195			`end;`
196			`end Reverse_String;`
197
198			`----------`
199			`-- Rpad --`
200			`----------`
201
202			`function Rpad`
203			`(Str : VString;`
204			`Len : Natural;`
205			`Pad : Character := ' ') return VString`
206			`is`
207			`begin`
208			`if Length (Str) >= Len then`
209			`return Str;`
210			`else`
211			`return Head (Str, Len, Pad);`
212			`end if;`
213			`end Rpad;`
214
215			`function Rpad`
216			`(Str : String;`
217			`Len : Natural;`
218			`Pad : Character := ' ') return VString`
219			`is`
220			`begin`
221			`if Str'Length >= Len then`
222			`return V (Str);`
223
224			`else`
225			`declare`
226			`R : String (1 .. Len);`
227
228			`begin`
229			`for J in Str'Length + 1 .. Len loop`
230			`R (J) := Pad;`
231			`end loop;`
232
233			`R (1 .. Str'Length) := Str;`
234			`return V (R);`
235			`end;`
236			`end if;`
237			`end Rpad;`
238
239			`procedure Rpad`
240			`(Str : in out VString;`
241			`Len : Natural;`
242			`Pad : Character := ' ')`
243			`is`
244			`begin`
245			`if Length (Str) >= Len then`
246			`return;`
247
248			`else`
249			`Head (Str, Len, Pad);`
250			`end if;`
251			`end Rpad;`
252
253			`-------`
254			`-- S --`
255			`-------`
256
257			`function S (Num : Integer) return String is`
258			`Buf : String (1 .. 30);`
259			`Ptr : Natural := Buf'Last + 1;`
260			`Val : Natural := abs (Num);`
261
262			`begin`
263			`loop`
264			`Ptr := Ptr - 1;`
265			`Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));`
266			`Val := Val / 10;`
267			`exit when Val = 0;`
268			`end loop;`
269
270			`if Num < 0 then`
271			`Ptr := Ptr - 1;`
272			`Buf (Ptr) := '-';`
273			`end if;`
274
275			`return Buf (Ptr .. Buf'Last);`
276			`end S;`
277
278			`------------`
279			`-- Substr --`
280			`------------`
281
282			`function Substr`
283			`(Str : VString;`
284			`Start : Positive;`
285			`Len : Natural) return VString`
286			`is`
287			`S : String_Access;`
288			`L : Natural;`
289
290			`begin`
291			`Get_String (Str, S, L);`
292
293			`if Start > L then`
294			`raise Index_Error;`
295			`elsif Start + Len - 1 > L then`
296			`raise Length_Error;`
297			`else`
298			`return V (S (Start .. Start + Len - 1));`
299			`end if;`
300			`end Substr;`
301
302			`function Substr`
303			`(Str : String;`
304			`Start : Positive;`
305			`Len : Natural) return VString`
306			`is`
307			`begin`
308			`if Start > Str'Length then`
309			`raise Index_Error;`
310			`elsif Start + Len > Str'Length then`
311			`raise Length_Error;`
312			`else`
313			`return`
314			`V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));`
315			`end if;`
316			`end Substr;`
317
318			`-----------`
319			`-- Table --`
320			`-----------`
321
322			`package body Table is`
323
324			`procedure Free is new`
325			`Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);`
326
327			`-----------------------`
328			`-- Local Subprograms --`
329			`-----------------------`
330
331			`function Hash is new System.String_Hash.Hash`
332			`(Character, String, Unsigned_32);`
333
334			`------------`
335			`-- Adjust --`
336			`------------`
337
338			`procedure Adjust (Object : in out Table) is`
339			`Ptr1 : Hash_Element_Ptr;`
340			`Ptr2 : Hash_Element_Ptr;`
341
342			`begin`
343			`for J in Object.Elmts'Range loop`
344			`Ptr1 := Object.Elmts (J)'Unrestricted_Access;`
345
346			`if Ptr1.Name /= null then`
347			`loop`
348			`Ptr1.Name := new String'(Ptr1.Name.all);`
349			`exit when Ptr1.Next = null;`
350			`Ptr2 := Ptr1.Next;`
351			`Ptr1.Next := new Hash_Element'(Ptr2.all);`
352			`Ptr1 := Ptr1.Next;`
353			`end loop;`
354			`end if;`
355			`end loop;`
356			`end Adjust;`
357
358			`-----------`
359			`-- Clear --`
360			`-----------`
361
362			`procedure Clear (T : in out Table) is`
363			`Ptr1 : Hash_Element_Ptr;`
364			`Ptr2 : Hash_Element_Ptr;`
365
366			`begin`
367			`for J in T.Elmts'Range loop`
368			`if T.Elmts (J).Name /= null then`
369			`Free (T.Elmts (J).Name);`
370			`T.Elmts (J).Value := Null_Value;`
371
372			`Ptr1 := T.Elmts (J).Next;`
373			`T.Elmts (J).Next := null;`
374
375			`while Ptr1 /= null loop`
376			`Ptr2 := Ptr1.Next;`
377			`Free (Ptr1.Name);`
378			`Free (Ptr1);`
379			`Ptr1 := Ptr2;`
380			`end loop;`
381			`end if;`
382			`end loop;`
383			`end Clear;`
384
385			`----------------------`
386			`-- Convert_To_Array --`
387			`----------------------`
388
389			`function Convert_To_Array (T : Table) return Table_Array is`
390			`Num_Elmts : Natural := 0;`
391			`Elmt : Hash_Element_Ptr;`
392
393			`begin`
394			`for J in T.Elmts'Range loop`
395			`Elmt := T.Elmts (J)'Unrestricted_Access;`
396
397			`if Elmt.Name /= null then`
398			`loop`
399			`Num_Elmts := Num_Elmts + 1;`
400			`Elmt := Elmt.Next;`
401			`exit when Elmt = null;`
402			`end loop;`
403			`end if;`
404			`end loop;`
405
406			`declare`
407			`TA : Table_Array (1 .. Num_Elmts);`
408			`P : Natural := 1;`
409
410			`begin`
411			`for J in T.Elmts'Range loop`
412			`Elmt := T.Elmts (J)'Unrestricted_Access;`
413
414			`if Elmt.Name /= null then`
415			`loop`
416			`Set_String (TA (P).Name, Elmt.Name.all);`
417			`TA (P).Value := Elmt.Value;`
418			`P := P + 1;`
419			`Elmt := Elmt.Next;`
420			`exit when Elmt = null;`
421			`end loop;`
422			`end if;`
423			`end loop;`
424
425			`return TA;`
426			`end;`
427			`end Convert_To_Array;`
428
429			`----------`
430			`-- Copy --`
431			`----------`
432
433			`procedure Copy (From : Table; To : in out Table) is`
434			`Elmt : Hash_Element_Ptr;`
435
436			`begin`
437			`Clear (To);`
438
439			`for J in From.Elmts'Range loop`
440			`Elmt := From.Elmts (J)'Unrestricted_Access;`
441			`if Elmt.Name /= null then`
442			`loop`
443			`Set (To, Elmt.Name.all, Elmt.Value);`
444			`Elmt := Elmt.Next;`
445			`exit when Elmt = null;`
446			`end loop;`
447			`end if;`
448			`end loop;`
449			`end Copy;`
450
451			`------------`
452			`-- Delete --`
453			`------------`
454
455			`procedure Delete (T : in out Table; Name : Character) is`
456			`begin`
457			`Delete (T, String'(1 => Name));`
458			`end Delete;`
459
460			`procedure Delete (T : in out Table; Name : VString) is`
461			`S : String_Access;`
462			`L : Natural;`
463			`begin`
464			`Get_String (Name, S, L);`
465			`Delete (T, S (1 .. L));`
466			`end Delete;`
467
468			`procedure Delete (T : in out Table; Name : String) is`
469			`Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;`
470			`Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;`
471			`Next : Hash_Element_Ptr;`
472
473			`begin`
474			`if Elmt.Name = null then`
475			`null;`
476
477			`elsif Elmt.Name.all = Name then`
478			`Free (Elmt.Name);`
479
480			`if Elmt.Next = null then`
481			`Elmt.Value := Null_Value;`
482			`return;`
483
484			`else`
485			`Next := Elmt.Next;`
486			`Elmt.Name := Next.Name;`
487			`Elmt.Value := Next.Value;`
488			`Elmt.Next := Next.Next;`
489			`Free (Next);`
490			`return;`
491			`end if;`
492
493			`else`
494			`loop`
495			`Next := Elmt.Next;`
496
497			`if Next = null then`
498			`return;`
499
500			`elsif Next.Name.all = Name then`
501			`Free (Next.Name);`
502			`Elmt.Next := Next.Next;`
503			`Free (Next);`
504			`return;`
505
506			`else`
507			`Elmt := Next;`
508			`end if;`
509			`end loop;`
510			`end if;`
511			`end Delete;`
512
513			`----------`
514			`-- Dump --`
515			`----------`
516
517			`procedure Dump (T : Table; Str : String := "Table") is`
518			`Num_Elmts : Natural := 0;`
519			`Elmt : Hash_Element_Ptr;`
520
521			`begin`
522			`for J in T.Elmts'Range loop`
523			`Elmt := T.Elmts (J)'Unrestricted_Access;`
524
525			`if Elmt.Name /= null then`
526			`loop`
527			`Num_Elmts := Num_Elmts + 1;`
528			`Put_Line`
529			`(Str & '<' & Image (Elmt.Name.all) & "> = " &`
530			`Img (Elmt.Value));`
531			`Elmt := Elmt.Next;`
532			`exit when Elmt = null;`
533			`end loop;`
534			`end if;`
535			`end loop;`
536
537			`if Num_Elmts = 0 then`
538			`Put_Line (Str & " is empty");`
539			`end if;`
540			`end Dump;`
541
542			`procedure Dump (T : Table_Array; Str : String := "Table_Array") is`
543			`begin`
544			`if T'Length = 0 then`
545			`Put_Line (Str & " is empty");`
546
547			`else`
548			`for J in T'Range loop`
549			`Put_Line`
550			`(Str & '(' & Image (To_String (T (J).Name)) & ") = " &`
551			`Img (T (J).Value));`
552			`end loop;`
553			`end if;`
554			`end Dump;`
555
556			`--------------`
557			`-- Finalize --`
558			`--------------`
559
560			`procedure Finalize (Object : in out Table) is`
561			`Ptr1 : Hash_Element_Ptr;`
562			`Ptr2 : Hash_Element_Ptr;`
563
564			`begin`
565			`for J in Object.Elmts'Range loop`
566			`Ptr1 := Object.Elmts (J).Next;`
567			`Free (Object.Elmts (J).Name);`
568			`while Ptr1 /= null loop`
569			`Ptr2 := Ptr1.Next;`
570			`Free (Ptr1.Name);`
571			`Free (Ptr1);`
572			`Ptr1 := Ptr2;`
573			`end loop;`
574			`end loop;`
575			`end Finalize;`
576
577			`---------`
578			`-- Get --`
579			`---------`
580
581			`function Get (T : Table; Name : Character) return Value_Type is`
582			`begin`
583			`return Get (T, String'(1 => Name));`
584			`end Get;`
585
586			`function Get (T : Table; Name : VString) return Value_Type is`
587			`S : String_Access;`
588			`L : Natural;`
589			`begin`
590			`Get_String (Name, S, L);`
591			`return Get (T, S (1 .. L));`
592			`end Get;`
593
594			`function Get (T : Table; Name : String) return Value_Type is`
595			`Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;`
596			`Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;`
597
598			`begin`
599			`if Elmt.Name = null then`
600			`return Null_Value;`
601
602			`else`
603			`loop`
604			`if Name = Elmt.Name.all then`
605			`return Elmt.Value;`
606
607			`else`
608			`Elmt := Elmt.Next;`
609
610			`if Elmt = null then`
611			`return Null_Value;`
612			`end if;`
613			`end if;`
614			`end loop;`
615			`end if;`
616			`end Get;`
617
618			`-------------`
619			`-- Present --`
620			`-------------`
621
622			`function Present (T : Table; Name : Character) return Boolean is`
623			`begin`
624			`return Present (T, String'(1 => Name));`
625			`end Present;`
626
627			`function Present (T : Table; Name : VString) return Boolean is`
628			`S : String_Access;`
629			`L : Natural;`
630			`begin`
631			`Get_String (Name, S, L);`
632			`return Present (T, S (1 .. L));`
633			`end Present;`
634
635			`function Present (T : Table; Name : String) return Boolean is`
636			`Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;`
637			`Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;`
638
639			`begin`
640			`if Elmt.Name = null then`
641			`return False;`
642
643			`else`
644			`loop`
645			`if Name = Elmt.Name.all then`
646			`return True;`
647
648			`else`
649			`Elmt := Elmt.Next;`
650
651			`if Elmt = null then`
652			`return False;`
653			`end if;`
654			`end if;`
655			`end loop;`
656			`end if;`
657			`end Present;`
658
659			`---------`
660			`-- Set --`
661			`---------`
662
663			`procedure Set (T : in out Table; Name : VString; Value : Value_Type) is`
664			`S : String_Access;`
665			`L : Natural;`
666			`begin`
667			`Get_String (Name, S, L);`
668			`Set (T, S (1 .. L), Value);`
669			`end Set;`
670
671			`procedure Set (T : in out Table; Name : Character; Value : Value_Type) is`
672			`begin`
673			`Set (T, String'(1 => Name), Value);`
674			`end Set;`
675
676			`procedure Set`
677			`(T : in out Table;`
678			`Name : String;`
679			`Value : Value_Type)`
680			`is`
681			`begin`
682			`if Value = Null_Value then`
683			`Delete (T, Name);`
684
685			`else`
686			`declare`
687			`Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;`
688			`Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;`
689
690			`subtype String1 is String (1 .. Name'Length);`
691
692			`begin`
693			`if Elmt.Name = null then`
694			`Elmt.Name := new String'(String1 (Name));`
695			`Elmt.Value := Value;`
696			`return;`
697
698			`else`
699			`loop`
700			`if Name = Elmt.Name.all then`
701			`Elmt.Value := Value;`
702			`return;`
703
704			`elsif Elmt.Next = null then`
705			`Elmt.Next := new Hash_Element'(`
706			`Name => new String'(String1 (Name)),`
707			`Value => Value,`
708			`Next => null);`
709			`return;`
710
711			`else`
712			`Elmt := Elmt.Next;`
713			`end if;`
714			`end loop;`
715			`end if;`
716			`end;`
717			`end if;`
718			`end Set;`
719			`end Table;`
720
721			`----------`
722			`-- Trim --`
723			`----------`
724
725			`function Trim (Str : VString) return VString is`
726			`begin`
727			`return Trim (Str, Right);`
728			`end Trim;`
729
730			`function Trim (Str : String) return VString is`
731			`begin`
732			`for J in reverse Str'Range loop`
733			`if Str (J) /= ' ' then`
734			`return V (Str (Str'First .. J));`
735			`end if;`
736			`end loop;`
737
738			`return Nul;`
739			`end Trim;`
740
741			`procedure Trim (Str : in out VString) is`
742			`begin`
743			`Trim (Str, Right);`
744			`end Trim;`
745
746			`-------`
747			`-- V --`
748			`-------`
749
750			`function V (Num : Integer) return VString is`
751			`Buf : String (1 .. 30);`
752			`Ptr : Natural := Buf'Last + 1;`
753			`Val : Natural := abs (Num);`
754
755			`begin`
756			`loop`
757			`Ptr := Ptr - 1;`
758			`Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));`
759			`Val := Val / 10;`
760			`exit when Val = 0;`
761			`end loop;`
762
763			`if Num < 0 then`
764			`Ptr := Ptr - 1;`
765			`Buf (Ptr) := '-';`
766			`end if;`
767
768			`return V (Buf (Ptr .. Buf'Last));`
769			`end V;`
770
771			`end GNAT.Spitbol;`