-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1998 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2007, 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- --
-- 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. --
+-- 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, --
-- 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). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
with GNAT.IO; use GNAT.IO;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
package body GNAT.Spitbol is
----------
function Lpad
- (Str : VString;
- Len : Natural;
- Pad : Character := ' ')
- return VString
+ (Str : VString;
+ Len : Natural;
+ Pad : Character := ' ') return VString
is
begin
if Length (Str) >= Len then
end Lpad;
function Lpad
- (Str : String;
- Len : Natural;
- Pad : Character := ' ')
- return VString
+ (Str : String;
+ Len : Natural;
+ Pad : Character := ' ') return VString
is
begin
if Str'Length >= Len then
-------
function N (Str : VString) return Integer is
+ S : String_Access;
+ L : Natural;
begin
- return Integer'Value (Get_String (Str).all);
+ Get_String (Str, S, L);
+ return Integer'Value (S (1 .. L));
end N;
--------------------
--------------------
function Reverse_String (Str : VString) return VString is
- Len : constant Natural := Length (Str);
- Result : String (1 .. Len);
- Chars : String_Access := Get_String (Str);
+ S : String_Access;
+ L : Natural;
begin
- for J in 1 .. Len loop
- Result (J) := Chars (Len + 1 - J);
- end loop;
+ Get_String (Str, S, L);
- return V (Result);
+ 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
end Reverse_String;
procedure Reverse_String (Str : in out VString) is
- Len : constant Natural := Length (Str);
- Chars : String_Access := Get_String (Str);
- Temp : Character;
+ S : String_Access;
+ L : Natural;
begin
- for J in 1 .. Len / 2 loop
- Temp := Chars (J);
- Chars (J) := Chars (Len + 1 - J);
- Chars (Len + 1 - J) := Temp;
- end loop;
+ 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;
----------
----------
function Rpad
- (Str : VString;
- Len : Natural;
- Pad : Character := ' ')
- return VString
+ (Str : VString;
+ Len : Natural;
+ Pad : Character := ' ') return VString
is
begin
if Length (Str) >= Len then
end Rpad;
function Rpad
- (Str : String;
- Len : Natural;
- Pad : Character := ' ')
- return VString
+ (Str : String;
+ Len : Natural;
+ Pad : Character := ' ') return VString
is
begin
if Str'Length >= Len then
function Substr
(Str : VString;
Start : Positive;
- Len : Natural)
- return VString
+ Len : Natural) return VString
is
+ S : String_Access;
+ L : Natural;
+
begin
- if Start > Length (Str) then
- raise Index_Error;
+ Get_String (Str, S, L);
- elsif Start + Len - 1 > Length (Str) then
+ if Start > L then
+ raise Index_Error;
+ elsif Start + Len - 1 > L then
raise Length_Error;
-
else
- return V (Get_String (Str).all (Start .. Start + Len - 1));
+ return V (S (Start .. Start + Len - 1));
end if;
end Substr;
function Substr
(Str : String;
Start : Positive;
- Len : Natural)
- return VString
+ 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));
package body Table is
procedure Free is new
- Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
+ Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
-----------------------
-- Local Subprograms --
-- Copy --
----------
- procedure Copy (From : in Table; To : in out Table) is
+ procedure Copy (From : Table; To : in out Table) is
Elmt : Hash_Element_Ptr;
begin
end Delete;
procedure Delete (T : in out Table; Name : VString) is
+ S : String_Access;
+ L : Natural;
begin
- Delete (T, Get_String (Name).all);
+ Get_String (Name, S, L);
+ Delete (T, S (1 .. L));
end Delete;
procedure Delete (T : in out Table; Name : String) is
end Get;
function Get (T : Table; Name : VString) return Value_Type is
+ S : String_Access;
+ L : Natural;
begin
- return Get (T, Get_String (Name).all);
+ Get_String (Name, S, L);
+ return Get (T, S (1 .. L));
end Get;
function Get (T : Table; Name : String) return Value_Type is
begin
for J in Str'Range loop
- Result := Rotate_Left (Result, 1) +
+ Result := Rotate_Left (Result, 3) +
Unsigned_32 (Character'Pos (Str (J)));
end loop;
end Present;
function Present (T : Table; Name : VString) return Boolean is
+ S : String_Access;
+ L : Natural;
begin
- return Present (T, Get_String (Name).all);
+ Get_String (Name, S, L);
+ return Present (T, S (1 .. L));
end Present;
function Present (T : Table; Name : String) return Boolean is
---------
procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
+ S : String_Access;
+ L : Natural;
begin
- Set (T, Get_String (Name).all, Value);
+ 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
OSDN Git Service
