X-Git-Url: https://oss.titaniummirror.com/gitweb/?a=blobdiff_plain;f=gcc%2Fada%2Fg-spitbo.adb;fp=gcc%2Fada%2Fg-spitbo.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=8fcb882a1f2b0eeb155e48fa65b281110569cbea;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb deleted file mode 100644 index 8fcb882a..00000000 --- a/gcc/ada/g-spitbo.adb +++ /dev/null @@ -1,764 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L -- --- -- --- B o d y -- --- -- --- $Revision: 1.1.16.1 $ --- -- --- Copyright (C) 1998 Ada Core Technologies, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - -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 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 - begin - return Integer'Value (Get_String (Str).all); - end N; - - -------------------- - -- Reverse_String -- - -------------------- - - function Reverse_String (Str : VString) return VString is - Len : constant Natural := Length (Str); - Result : String (1 .. Len); - Chars : String_Access := Get_String (Str); - - begin - for J in 1 .. Len loop - Result (J) := Chars (Len + 1 - J); - end loop; - - return V (Result); - 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 - Len : constant Natural := Length (Str); - Chars : String_Access := Get_String (Str); - Temp : Character; - - begin - for J in 1 .. Len / 2 loop - Temp := Chars (J); - Chars (J) := Chars (Len + 1 - J); - Chars (Len + 1 - J) := Temp; - end loop; - 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 - begin - if Start > Length (Str) then - raise Index_Error; - - elsif Start + Len - 1 > Length (Str) then - raise Length_Error; - - else - return V (Get_String (Str).all (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 - Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Hash (Str : String) return Unsigned_32; - -- Compute hash function for given String - - ------------ - -- 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 : in 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 - begin - Delete (T, Get_String (Name).all); - 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 - begin - return Get (T, Get_String (Name).all); - 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; - - ---------- - -- Hash -- - ---------- - - function Hash (Str : String) return Unsigned_32 is - Result : Unsigned_32 := Str'Length; - - begin - for J in Str'Range loop - Result := Rotate_Left (Result, 1) + - Unsigned_32 (Character'Pos (Str (J))); - end loop; - - return Result; - end Hash; - - ------------- - -- 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 - begin - return Present (T, Get_String (Name).all); - 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 - begin - Set (T, Get_String (Name).all, 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;