diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/g-spitbo.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/g-spitbo.adb | 769 |
1 files changed, 0 insertions, 769 deletions
diff --git a/gcc-4.8/gcc/ada/g-spitbo.adb b/gcc-4.8/gcc/ada/g-spitbo.adb deleted file mode 100644 index 22677149e..000000000 --- a/gcc-4.8/gcc/ada/g-spitbo.adb +++ /dev/null @@ -1,769 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2012, 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 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 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 : Big_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 : Big_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 : Big_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_Unbounded_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 : Big_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 - 1 > 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_Unbounded_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 : Big_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 : Big_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 : Big_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 : Big_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; |