[Ada] PR ada/13470

Arnaud Charlet charlet@adacore.com
Tue Mar 15 14:50:00 GMT 2005


Tested on i686-linux. Committed on mainline.

PR ada/13470

When Ada.Strings.Unbounded (and the corresponding wide packages) were
rewritten to improve performance by allowing extra expansion space in
unbounded strings, the routines for direct access to the internal
fields of an unbounded string became at the same time very inefficient
(because extra space was removed even for just a read only reference
and an extra copy done), and also incorrect (since the modified version
of Get_Line modified its parameter which is a read only constant). This
patch changes the interface to Get_String in particular so that it can
now be implemented correctly and efficiently. This change is also the
proper clean fix for PR ada/13470, which was about the compiler doing
an "incorrect" optimization based on the assumption that the constant
in parameter was not modified. It turns out that this optimization
though strictly correct, is a bit unfriendly, and in another patch,
we will make sure that this optimization is suppressed for parameters
whose address is taken, but that's not relevant here any more, since
the new interface is much cleaner and avoids the rather nasty kludge
of modifying an in parameter.

At the same time, the implementation of Set_String has been improved
and stream lined to be more efficient (though there was no functional
problem there).

All references to Get_String have been modified to use the new interface,
and one instance in s-spitbo.adb where the rule about not modifying the
data referenced by the pointer returned by Get_String was violated has
been fixed to avoid violating this rule.

In the Unbounded.Text_IO units, the use of Get_String and Set_String
has simply been eliminated (this usage was gratuitous, because these
units are children of Unbounded and have full access to the internal
representation of Unbounded_String in any case.

2005-03-08  Robert Dewar  <dewar@adacore.com>

	PR ada/13470

	* a-stunau.ads, a-stunau.adb: 
	Change interface to allow efficient (and correct) implementation
	The previous changes to allow extra space in unbounded strings had
	left this interface a bit broken.

	* a-suteio.adb: Avoid unnecessary use of Get/Set_String

	* g-spipat.ads, g-spipat.adb: New interface for Get_String
	Minor reformatting (function specs)

	* g-spitbo.adb: New interface for Get_String

	* g-spitbo.ads: Minor reformatting

	* a-swunau.ads, a-swunau.adb: New interface for Get_Wide_String

	* a-szunau.ads, a-szunau.adb: New interface for Get_Wide_Wide_String

-------------- next part --------------
Index: a-stunau.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-stunau.ads,v
retrieving revision 1.6
diff -u -p -r1.6 a-stunau.ads
--- a-stunau.ads	10 Feb 2005 13:50:15 -0000	1.6
+++ a-stunau.ads	15 Mar 2005 13:54:57 -0000
@@ -39,19 +39,22 @@
 package Ada.Strings.Unbounded.Aux is
 pragma Preelaborate (Aux);
 
-   function Get_String (U : Unbounded_String) return String_Access;
+   procedure Get_String
+     (U : Unbounded_String;
+      S : out String_Access;
+      L : out Natural);
    pragma Inline (Get_String);
-   --  This function returns the internal string pointer used in the
-   --  representation of an unbounded string. There is no copy involved,
-   --  so the value obtained references the same string as the original
-   --  unbounded string. The characters of this string may not be modified
-   --  via the returned pointer, and are valid only as long as the original
-   --  unbounded string is not modified. Violating either of these two
-   --  rules results in erroneous execution.
+   --  This procedure returns the internal string pointer used in the
+   --  representation of an unbounded string as well as the actual current
+   --  length (which may be less than S.all'Length because in general there
+   --  can be extra space assigned). The characters of this string may be
+   --  not be modified via the returned pointer,  and are valid only as
+   --  long as the original unbounded string is not accessed or modified.
    --
-   --  This function is much more efficient than the use of To_String
+   --  This procedure is much more efficient than the use of To_String
    --  since it avoids the need to copy the string. The lower bound of the
-   --  referenced string returned by this call is always one.
+   --  referenced string returned by this call is always one, so the actual
+   --  string data is always accessible as S (1 .. L).
 
    procedure Set_String (UP : in out Unbounded_String; S : String);
    pragma Inline (Set_String);
Index: a-stunau.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-stunau.adb,v
retrieving revision 1.6
diff -u -p -r1.6 a-stunau.adb
--- a-stunau.adb	18 Jan 2005 22:00:12 -0000	1.6
+++ a-stunau.adb	15 Mar 2005 13:54:57 -0000
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2005, Free Software Foundation, 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- --
@@ -37,31 +37,14 @@ package body Ada.Strings.Unbounded.Aux i
    -- Get_String --
    ----------------
 
-   function Get_String (U : Unbounded_String) return String_Access is
+   procedure Get_String
+     (U : Unbounded_String;
+      S : out String_Access;
+      L : out Natural)
+   is
    begin
-      if U.Last = U.Reference'Length then
-         return U.Reference;
-
-      else
-         declare
-            type Unbounded_String_Access is access all Unbounded_String;
-
-            U_Ptr : constant Unbounded_String_Access := U'Unrestricted_Access;
-            --  Unbounded_String is a controlled type which is always passed
-            --  by reference.  It is always safe to take the pointer to such
-            --  object here.  This pointer is used to set the U.Reference
-            --  value which would not be possible otherwise as U is read-only.
-
-            Old : String_Access := U.Reference;
-            Ret : String_Access;
-
-         begin
-            Ret := new String'(U.Reference (1 .. U.Last));
-            U_Ptr.Reference := Ret;
-            Free (Old);
-            return Ret;
-         end;
-      end if;
+      S := U.Reference;
+      L := U.Last;
    end Get_String;
 
    ----------------
@@ -70,21 +53,13 @@ package body Ada.Strings.Unbounded.Aux i
 
    procedure Set_String (UP : in out Unbounded_String; S : String) is
    begin
-      if UP.Last = S'Length then
-         UP.Reference.all := S;
-
-      else
-         declare
-            subtype String_1 is String (1 .. S'Length);
-            Tmp : String_Access;
-
-         begin
-            Tmp := new String'(String_1 (S));
-            Finalize (UP);
-            UP.Reference := Tmp;
-            UP.Last := UP.Reference'Length;
-         end;
+      if S'Length > UP.Last then
+         Finalize (UP);
+         UP.Reference := new String (1 .. S'Length);
       end if;
+
+      UP.Reference (1 .. S'Length) := S;
+      UP.Last := S'Length;
    end Set_String;
 
    procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
Index: a-suteio.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-suteio.adb,v
retrieving revision 1.5
diff -u -p -r1.5 a-suteio.adb
--- a-suteio.adb	10 Feb 2005 13:50:14 -0000	1.5
+++ a-suteio.adb	15 Mar 2005 13:54:57 -0000
@@ -31,8 +31,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
-with Ada.Text_IO;               use Ada.Text_IO;
+with Ada.Text_IO; use Ada.Text_IO;
 
 package body Ada.Strings.Unbounded.Text_IO is
 
@@ -57,7 +56,8 @@ package body Ada.Strings.Unbounded.Text_
          Str1 := Str2;
       end loop;
 
-      Set_String (Result, Str1);
+      Result.Reference := Str1;
+      Result.Last      := Str1'Length;
       return Result;
    end Get_Line;
 
@@ -78,49 +78,52 @@ package body Ada.Strings.Unbounded.Text_
          Str1 := Str2;
       end loop;
 
-      Set_String (Result, Str1);
+      Result.Reference := Str1;
+      Result.Last      := Str1'Length;
       return Result;
    end Get_Line;
 
    procedure Get_Line (Item : out Unbounded_String) is
-      Buffer : String (1 .. 1000);
-      Last   : Natural;
-      Str1   : String_Access;
-      Str2   : String_Access;
-
    begin
-      Get_Line (Buffer, Last);
-      Str1 := new String'(Buffer (1 .. Last));
-      while Last = Buffer'Last loop
-         Get_Line (Buffer, Last);
-         Str2 := new String'(Str1.all & Buffer (1 .. Last));
-         Free (Str1);
-         Str1 := Str2;
-      end loop;
-
-      Set_String (Item, Str1);
+      Get_Line (Current_Input, Item);
    end Get_Line;
 
    procedure Get_Line
      (File : Ada.Text_IO.File_Type;
       Item : out Unbounded_String)
    is
-      Buffer : String (1 .. 1000);
-      Last   : Natural;
-      Str1   : String_Access;
-      Str2   : String_Access;
-
    begin
-      Get_Line (File, Buffer, Last);
-      Str1 := new String'(Buffer (1 .. Last));
-      while Last = Buffer'Last loop
-         Get_Line (Buffer, Last);
-         Str2 := new String'(Str1.all & Buffer (1 .. Last));
-         Free (Str1);
-         Str1 := Str2;
-      end loop;
+      --  We are going to read into the string that is already there and
+      --  allocated. Hopefully it is big enough now, if not, we will extend
+      --  it in the usual manner using Realloc_For_Chunk.
 
-      Set_String (Item, Str1);
+      --  Make sure we start with at least 80 characters
+
+      if Item.Reference'Last < 80 then
+         Realloc_For_Chunk (Item, 80);
+      end if;
+
+      --  Loop to read data, filling current string as far as possible.
+      --  Item.Last holds the number of characters read so far.
+
+      Item.Last := 0;
+      loop
+         Get_Line
+           (File,
+            Item.Reference (Item.Last + 1 .. Item.Reference'Last),
+            Item.Last);
+
+         --  If we hit the end of the line before the end of the buffer, then
+         --  we are all done, and the result length is properly set.
+
+         if Item.Last < Item.Reference'Last then
+            return;
+         end if;
+
+         --  If not enough room, double it and keep reading
+
+         Realloc_For_Chunk (Item, Item.Last);
+      end loop;
    end Get_Line;
 
    ---------
@@ -129,12 +132,12 @@ package body Ada.Strings.Unbounded.Text_
 
    procedure Put (U : Unbounded_String) is
    begin
-      Put (Get_String (U).all);
+      Put (U.Reference (1 .. U.Last));
    end Put;
 
    procedure Put (File : File_Type; U : Unbounded_String) is
    begin
-      Put (File, Get_String (U).all);
+      Put (File, U.Reference (1 .. U.Last));
    end Put;
 
    --------------
@@ -143,12 +146,12 @@ package body Ada.Strings.Unbounded.Text_
 
    procedure Put_Line (U : Unbounded_String) is
    begin
-      Put_Line (Get_String (U).all);
+      Put_Line (U.Reference (1 .. U.Last));
    end Put_Line;
 
    procedure Put_Line (File : File_Type; U : Unbounded_String) is
    begin
-      Put_Line (File, Get_String (U).all);
+      Put_Line (File, U.Reference (1 .. U.Last));
    end Put_Line;
 
 end Ada.Strings.Unbounded.Text_IO;
Index: g-spipat.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spipat.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-spipat.ads
--- g-spipat.ads	21 Oct 2003 13:42:05 -0000	1.4
+++ g-spipat.ads	15 Mar 2005 13:54:57 -0000
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---           Copyright (C) 1997-2002 Ada Core Technologies, Inc.            --
+--           Copyright (C) 1997-2005 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- --
@@ -953,23 +953,19 @@ pragma Elaborate_Body (Patterns);
 
    function Match
      (Subject : VString;
-      Pat     : Pattern)
-      return    Boolean;
+      Pat     : Pattern) return Boolean;
 
    function Match
      (Subject : VString;
-      Pat     : PString)
-      return    Boolean;
+      Pat     : PString) return Boolean;
 
    function Match
      (Subject : String;
-      Pat     : Pattern)
-      return    Boolean;
+      Pat     : Pattern) return Boolean;
 
    function Match
      (Subject : String;
-      Pat     : PString)
-      return    Boolean;
+      Pat     : PString) return Boolean;
 
    --  Replacement functions. The subject is matched against the pattern.
    --  Any immediate or deferred assignments or writes are executed, and
@@ -980,26 +976,22 @@ pragma Elaborate_Body (Patterns);
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Replace : VString)
-      return    Boolean;
+      Replace : VString) return Boolean;
 
    function Match
      (Subject : VString_Var;
       Pat     : PString;
-      Replace : VString)
-      return    Boolean;
+      Replace : VString) return Boolean;
 
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Replace : String)
-      return    Boolean;
+      Replace : String) return Boolean;
 
    function Match
      (Subject : VString_Var;
       Pat     : PString;
-      Replace : String)
-      return    Boolean;
+      Replace : String) return Boolean;
 
    --  Simple match procedures. The subject is matched against the pattern.
    --  Any immediate or deferred assignments or writes are executed. No
@@ -1063,8 +1055,7 @@ pragma Elaborate_Body (Patterns);
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Result  : Match_Result_Var)
-      return    Boolean;
+      Result  : Match_Result_Var) return Boolean;
 
    procedure Match
      (Subject : in out VString;
Index: g-spipat.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spipat.adb,v
retrieving revision 1.8
diff -u -p -r1.8 g-spipat.adb
--- g-spipat.adb	4 Oct 2004 14:59:42 -0000	1.8
+++ g-spipat.adb	15 Mar 2005 13:54:57 -0000
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 1998-2004, Ada Core Technologies, Inc.           --
+--           Copyright (C) 1998-2005, 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- --
@@ -2802,16 +2802,20 @@ package body GNAT.Spitbol.Patterns is
 
    function Match
      (Subject : VString;
-      Pat     : Pattern)
-      return    Boolean
+      Pat     : Pattern) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       return Start /= 0;
@@ -2819,8 +2823,7 @@ package body GNAT.Spitbol.Patterns is
 
    function Match
      (Subject : String;
-      Pat     : Pattern)
-      return    Boolean
+      Pat     : Pattern) return Boolean
    is
       Start, Stop : Natural;
       subtype String1 is String (1 .. Subject'Length);
@@ -2838,24 +2841,28 @@ package body GNAT.Spitbol.Patterns is
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Replace : VString)
-      return    Boolean
+      Replace : VString) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start = 0 then
          return False;
       else
+         Get_String (Replace, S, L);
          Replace_Slice
-           (Subject'Unrestricted_Access.all,
-            Start, Stop, Get_String (Replace).all);
+           (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
          return True;
       end if;
    end Match;
@@ -2863,16 +2870,20 @@ package body GNAT.Spitbol.Patterns is
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Replace : String)
-      return    Boolean
+      Replace : String) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start = 0 then
@@ -2888,15 +2899,19 @@ package body GNAT.Spitbol.Patterns is
      (Subject : VString;
       Pat     : Pattern)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
-
    end Match;
 
    procedure Match
@@ -2918,17 +2933,23 @@ package body GNAT.Spitbol.Patterns is
       Pat     : Pattern;
       Replace : VString)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start /= 0 then
-         Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
+         Get_String (Replace, S, L);
+         Replace_Slice (Subject, Start, Stop, S (1 .. L));
       end if;
    end Match;
 
@@ -2937,13 +2958,18 @@ package body GNAT.Spitbol.Patterns is
       Pat     : Pattern;
       Replace : String)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start /= 0 then
@@ -2953,24 +2979,25 @@ package body GNAT.Spitbol.Patterns is
 
    function Match
      (Subject : VString;
-      Pat     : PString)
-      return    Boolean
+      Pat     : PString) return Boolean
    is
-      Pat_Len : constant Natural       := Pat'Length;
-      Sub_Len : constant Natural       := Length (Subject);
-      Sub_Str : constant String_Access := Get_String (Subject);
+      Pat_Len : constant Natural := Pat'Length;
+      S       : String_Access;
+      L       : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Anchored_Mode then
-         if Pat_Len > Sub_Len then
+         if Pat_Len > L then
             return False;
          else
-            return Pat = Sub_Str.all (1 .. Pat_Len);
+            return Pat = S (1 .. Pat_Len);
          end if;
 
       else
-         for J in 1 .. Sub_Len - Pat_Len + 1 loop
-            if Pat = Sub_Str.all (J .. J + (Pat_Len - 1)) then
+         for J in 1 .. L - Pat_Len + 1 loop
+            if Pat = S (J .. J + (Pat_Len - 1)) then
                return True;
             end if;
          end loop;
@@ -2981,8 +3008,7 @@ package body GNAT.Spitbol.Patterns is
 
    function Match
      (Subject : String;
-      Pat     : PString)
-      return    Boolean
+      Pat     : PString) return Boolean
    is
       Pat_Len : constant Natural := Pat'Length;
       Sub_Len : constant Natural := Subject'Length;
@@ -3010,24 +3036,28 @@ package body GNAT.Spitbol.Patterns is
    function Match
      (Subject : VString_Var;
       Pat     : PString;
-      Replace : VString)
-      return    Boolean
+      Replace : VString) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatch  (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       end if;
 
       if Start = 0 then
          return False;
       else
+         Get_String (Replace, S, L);
          Replace_Slice
-           (Subject'Unrestricted_Access.all,
-            Start, Stop, Get_String (Replace).all);
+           (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L));
          return True;
       end if;
    end Match;
@@ -3035,16 +3065,20 @@ package body GNAT.Spitbol.Patterns is
    function Match
      (Subject : VString_Var;
       Pat     : PString;
-      Replace : String)
-      return    Boolean
+      Replace : String) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatch  (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       end if;
 
       if Start = 0 then
@@ -3060,13 +3094,18 @@ package body GNAT.Spitbol.Patterns is
      (Subject : VString;
       Pat     : PString)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatch  (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       end if;
    end Match;
 
@@ -3090,17 +3129,23 @@ package body GNAT.Spitbol.Patterns is
       Pat     : PString;
       Replace : VString)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatch  (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       end if;
 
       if Start /= 0 then
-         Replace_Slice (Subject, Start, Stop, Get_String (Replace).all);
+         Get_String (Replace, S, L);
+         Replace_Slice (Subject, Start, Stop, S (1 .. L));
       end if;
    end Match;
 
@@ -3109,13 +3154,18 @@ package body GNAT.Spitbol.Patterns is
       Pat     : PString;
       Replace : String)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, S_To_PE (Pat), 0, Start, Stop);
+         XMatch  (S (1 .. L), S_To_PE (Pat), 0, Start, Stop);
       end if;
 
       if Start /= 0 then
@@ -3126,16 +3176,20 @@ package body GNAT.Spitbol.Patterns is
    function Match
      (Subject : VString_Var;
       Pat     : Pattern;
-      Result  : Match_Result_Var)
-      return    Boolean
+      Result  : Match_Result_Var) return Boolean
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start = 0 then
@@ -3155,18 +3209,22 @@ package body GNAT.Spitbol.Patterns is
       Pat     : Pattern;
       Result  : out Match_Result)
    is
-      Start, Stop : Natural;
+      Start : Natural;
+      Stop  : Natural;
+      S     : String_Access;
+      L     : Natural;
 
    begin
+      Get_String (Subject, S, L);
+
       if Debug_Mode then
-         XMatchD (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       else
-         XMatch  (Get_String (Subject).all, Pat.P, Pat.Stk, Start, Stop);
+         XMatch  (S (1 .. L), Pat.P, Pat.Stk, Start, Stop);
       end if;
 
       if Start = 0 then
          Result.Var := null;
-
       else
          Result.Var   := Subject'Unrestricted_Access;
          Result.Start := Start;
@@ -3302,13 +3360,14 @@ package body GNAT.Spitbol.Patterns is
      (Result  : in out Match_Result;
       Replace : VString)
    is
+      S : String_Access;
+      L : Natural;
+
    begin
+      Get_String (Replace, S, L);
+
       if Result.Var /= null then
-         Replace_Slice
-           (Result.Var.all,
-            Result.Start,
-            Result.Stop,
-            Get_String (Replace).all);
+         Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L));
          Result.Var := null;
       end if;
    end Replace;
@@ -3487,7 +3546,6 @@ package body GNAT.Spitbol.Patterns is
 
    function Str_BF (A : Boolean_Func) return String is
       function To_A is new Unchecked_Conversion (Boolean_Func, Address);
-
    begin
       return "BF(" & Image (To_A (A)) & ')';
    end Str_BF;
@@ -3507,7 +3565,6 @@ package body GNAT.Spitbol.Patterns is
 
    function Str_NF (A : Natural_Func) return String is
       function To_A is new Unchecked_Conversion (Natural_Func, Address);
-
    begin
       return "NF(" & Image (To_A (A)) & ')';
    end Str_NF;
@@ -3536,7 +3593,6 @@ package body GNAT.Spitbol.Patterns is
 
    function Str_VF (A : VString_Func) return String is
       function To_A is new Unchecked_Conversion (VString_Func, Address);
-
    begin
       return "VF(" & Image (To_A (A)) & ')';
    end Str_VF;
@@ -3897,12 +3953,15 @@ package body GNAT.Spitbol.Patterns is
          --  Any (string function case)
 
          when PC_Any_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             if Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -3914,11 +3973,15 @@ package body GNAT.Spitbol.Patterns is
          --  Any (string pointer case)
 
          when PC_Any_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             if Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -4077,12 +4140,15 @@ package body GNAT.Spitbol.Patterns is
          --  Break (string function case)
 
          when PC_Break_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -4095,11 +4161,15 @@ package body GNAT.Spitbol.Patterns is
          --  Break (string pointer case)
 
          when PC_Break_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -4138,12 +4208,15 @@ package body GNAT.Spitbol.Patterns is
          --  BreakX (string function case)
 
          when PC_BreakX_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -4156,11 +4229,15 @@ package body GNAT.Spitbol.Patterns is
          --  BreakX (string pointer case)
 
          when PC_BreakX_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -4298,13 +4375,16 @@ package body GNAT.Spitbol.Patterns is
          --  NotAny (string function case)
 
          when PC_NotAny_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             if Cursor < Length
               and then
-                not Is_In (Subject (Cursor + 1), Str.all)
+                not Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -4316,12 +4396,16 @@ package body GNAT.Spitbol.Patterns is
          --  NotAny (string pointer case)
 
          when PC_NotAny_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             if Cursor < Length
               and then
-                not Is_In (Subject (Cursor + 1), Str.all)
+                not Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -4355,12 +4439,15 @@ package body GNAT.Spitbol.Patterns is
          --  NSpan (string function case)
 
          when PC_NSpan_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             loop
                Cursor := Cursor + 1;
             end loop;
@@ -4371,11 +4458,15 @@ package body GNAT.Spitbol.Patterns is
          --  NSpan (string pointer case)
 
          when PC_NSpan_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
+            Get_String (U, S, L);
+
             while Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             loop
                Cursor := Cursor + 1;
             end loop;
@@ -4591,13 +4682,17 @@ package body GNAT.Spitbol.Patterns is
          --  Span (string function case)
 
          when PC_Span_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
-            P   : Natural := Cursor;
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
+            P : Natural;
 
          begin
+            Get_String (U, S, L);
+
+            P := Cursor;
             while P < Length
-              and then Is_In (Subject (P + 1), Str.all)
+              and then Is_In (Subject (P + 1), S (1 .. L))
             loop
                P := P + 1;
             end loop;
@@ -4613,12 +4708,17 @@ package body GNAT.Spitbol.Patterns is
          --  Span (string pointer case)
 
          when PC_Span_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
-            P   : Natural := Cursor;
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
+            P : Natural;
 
          begin
+            Get_String (U, S, L);
+
+            P := Cursor;
             while P < Length
-              and then Is_In (Subject (P + 1), Str.all)
+              and then Is_In (Subject (P + 1), S (1 .. L))
             loop
                P := P + 1;
             end loop;
@@ -4710,15 +4810,17 @@ package body GNAT.Spitbol.Patterns is
          --  String (function case)
 
          when PC_String_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
-            Len : constant Natural       := Str'Length;
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            if (Length - Cursor) >= Len
-              and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
+            Get_String (U, S, L);
+
+            if (Length - Cursor) >= L
+              and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
             then
-               Cursor := Cursor + Len;
+               Cursor := Cursor + L;
                goto Succeed;
             else
                goto Fail;
@@ -4728,14 +4830,17 @@ package body GNAT.Spitbol.Patterns is
          --  String (pointer case)
 
          when PC_String_VP => declare
-            S   : constant String_Access := Get_String (Node.VP.all);
-            Len : constant Natural       := S'Length;
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            if (Length - Cursor) >= Len
-              and then S.all = Subject (Cursor + 1 .. Cursor + Len)
+            Get_String (U, S, L);
+
+            if (Length - Cursor) >= L
+              and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
             then
-               Cursor := Cursor + Len;
+               Cursor := Cursor + L;
                goto Succeed;
             else
                goto Fail;
@@ -5251,14 +5356,17 @@ package body GNAT.Spitbol.Patterns is
          --  Any (string function case)
 
          when PC_Any_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching Any", Str.all);
+            Get_String (U, S, L);
+
+            Dout (Img (Node) & "matching Any", S (1 .. L));
 
             if Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -5270,13 +5378,16 @@ package body GNAT.Spitbol.Patterns is
          --  Any (string pointer case)
 
          when PC_Any_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching Any", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching Any", S (1 .. L));
 
             if Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -5454,14 +5565,16 @@ package body GNAT.Spitbol.Patterns is
          --  Break (string function case)
 
          when PC_Break_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching Break", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching Break", S (1 .. L));
 
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -5474,13 +5587,16 @@ package body GNAT.Spitbol.Patterns is
          --  Break (string pointer case)
 
          when PC_Break_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching Break", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching Break", S (1 .. L));
 
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -5523,14 +5639,16 @@ package body GNAT.Spitbol.Patterns is
          --  BreakX (string function case)
 
          when PC_BreakX_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching BreakX", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching BreakX", S (1 .. L));
 
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -5543,13 +5661,16 @@ package body GNAT.Spitbol.Patterns is
          --  BreakX (string pointer case)
 
          when PC_BreakX_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching BreakX", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching BreakX", S (1 .. L));
 
             while Cursor < Length loop
-               if Is_In (Subject (Cursor + 1), Str.all) then
+               if Is_In (Subject (Cursor + 1), S (1 .. L)) then
                   goto Succeed;
                else
                   Cursor := Cursor + 1;
@@ -5565,7 +5686,6 @@ package body GNAT.Spitbol.Patterns is
 
          when PC_BreakX_X =>
             Dout (Img (Node) & "extending BreakX");
-
             Cursor := Cursor + 1;
             goto Succeed;
 
@@ -5708,15 +5828,17 @@ package body GNAT.Spitbol.Patterns is
          --  NotAny (string function case)
 
          when PC_NotAny_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching NotAny", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching NotAny", S (1 .. L));
 
             if Cursor < Length
               and then
-                not Is_In (Subject (Cursor + 1), Str.all)
+                not Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -5728,14 +5850,17 @@ package body GNAT.Spitbol.Patterns is
          --  NotAny (string pointer case)
 
          when PC_NotAny_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching NotAny", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching NotAny", S (1 .. L));
 
             if Cursor < Length
               and then
-                not Is_In (Subject (Cursor + 1), Str.all)
+                not Is_In (Subject (Cursor + 1), S (1 .. L))
             then
                Cursor := Cursor + 1;
                goto Succeed;
@@ -5773,14 +5898,16 @@ package body GNAT.Spitbol.Patterns is
          --  NSpan (string function case)
 
          when PC_NSpan_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching NSpan", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching NSpan", S (1 .. L));
 
             while Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             loop
                Cursor := Cursor + 1;
             end loop;
@@ -5791,13 +5918,16 @@ package body GNAT.Spitbol.Patterns is
          --  NSpan (string pointer case)
 
          when PC_NSpan_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching NSpan", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching NSpan", S (1 .. L));
 
             while Cursor < Length
-              and then Is_In (Subject (Cursor + 1), Str.all)
+              and then Is_In (Subject (Cursor + 1), S (1 .. L))
             loop
                Cursor := Cursor + 1;
             end loop;
@@ -6044,15 +6174,18 @@ package body GNAT.Spitbol.Patterns is
          --  Span (string function case)
 
          when PC_Span_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
-            P   : Natural := Cursor;
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
+            P : Natural;
 
          begin
-            Dout (Img (Node) & "matching Span", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching Span", S (1 .. L));
 
+            P := Cursor;
             while P < Length
-              and then Is_In (Subject (P + 1), Str.all)
+              and then Is_In (Subject (P + 1), S (1 .. L))
             loop
                P := P + 1;
             end loop;
@@ -6068,14 +6201,18 @@ package body GNAT.Spitbol.Patterns is
          --  Span (string pointer case)
 
          when PC_Span_VP => declare
-            Str : constant String_Access := Get_String (Node.VP.all);
-            P   : Natural := Cursor;
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
+            P : Natural;
 
          begin
-            Dout (Img (Node) & "matching Span", Str.all);
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching Span", S (1 .. L));
 
+            P := Cursor;
             while P < Length
-              and then Is_In (Subject (P + 1), Str.all)
+              and then Is_In (Subject (P + 1), S (1 .. L))
             loop
                P := P + 1;
             end loop;
@@ -6179,17 +6316,18 @@ package body GNAT.Spitbol.Patterns is
          --  String (function case)
 
          when PC_String_VF => declare
-            U   : constant VString       := Node.VF.all;
-            Str : constant String_Access := Get_String (U);
-            Len : constant Natural       := Str'Length;
+            U : constant VString := Node.VF.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout (Img (Node) & "matching " & Image (Str.all));
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching " & Image (S (1 .. L)));
 
-            if (Length - Cursor) >= Len
-              and then Str.all = Subject (Cursor + 1 .. Cursor + Len)
+            if (Length - Cursor) >= L
+              and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
             then
-               Cursor := Cursor + Len;
+               Cursor := Cursor + L;
                goto Succeed;
             else
                goto Fail;
@@ -6199,18 +6337,18 @@ package body GNAT.Spitbol.Patterns is
          --  String (vstring pointer case)
 
          when PC_String_VP => declare
-            S   : constant String_Access := Get_String (Node.VP.all);
-            Len : constant Natural :=
-                    Ada.Strings.Unbounded.Length (Node.VP.all);
+            U : constant VString := Node.VP.all;
+            S : String_Access;
+            L : Natural;
 
          begin
-            Dout
-              (Img (Node) & "matching " & Image (S.all));
+            Get_String (U, S, L);
+            Dout (Img (Node) & "matching " & Image (S (1 .. L)));
 
-            if (Length - Cursor) >= Len
-              and then S.all = Subject (Cursor + 1 .. Cursor + Len)
+            if (Length - Cursor) >= L
+              and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L)
             then
-               Cursor := Cursor + Len;
+               Cursor := Cursor + L;
                goto Succeed;
             else
                goto Fail;
Index: g-spitbo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spitbo.adb,v
retrieving revision 1.5
diff -u -p -r1.5 g-spitbo.adb
--- g-spitbo.adb	13 Jan 2004 11:51:33 -0000	1.5
+++ g-spitbo.adb	15 Mar 2005 13:54:57 -0000
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---            Copyright (C) 1998-2002 Ada Core Technologies, Inc.           --
+--            Copyright (C) 1998-2005 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- --
@@ -79,10 +79,9 @@ 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
@@ -93,10 +92,9 @@ package body GNAT.Spitbol is
    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
@@ -135,8 +133,11 @@ package body GNAT.Spitbol is
    -------
 
    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;
 
    --------------------
@@ -144,16 +145,22 @@ package body GNAT.Spitbol is
    --------------------
 
    function Reverse_String (Str : VString) return VString is
-      Len    : constant Natural       := Length (Str);
-      Chars  : constant String_Access := Get_String (Str);
-      Result : String (1 .. Len);
+      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
@@ -168,16 +175,22 @@ package body GNAT.Spitbol is
    end Reverse_String;
 
    procedure Reverse_String (Str : in out VString) is
-      Len    : constant Natural := Length (Str);
-      Chars  : constant 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;
 
    ----------
@@ -185,10 +198,9 @@ package body GNAT.Spitbol is
    ----------
 
    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
@@ -199,10 +211,9 @@ package body GNAT.Spitbol is
    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
@@ -269,34 +280,33 @@ package body GNAT.Spitbol is
    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));
@@ -446,8 +456,11 @@ package body GNAT.Spitbol is
       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
@@ -569,8 +582,11 @@ package body GNAT.Spitbol 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
@@ -623,8 +639,11 @@ package body GNAT.Spitbol is
       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
@@ -656,8 +675,11 @@ package body GNAT.Spitbol 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
Index: g-spitbo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-spitbo.ads,v
retrieving revision 1.4
diff -u -p -r1.4 g-spitbo.ads
--- g-spitbo.ads	21 Oct 2003 13:42:05 -0000	1.4
+++ g-spitbo.ads	15 Mar 2005 13:54:57 -0000
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---           Copyright (C) 1997-1999 Ada Core Technologies, Inc.            --
+--           Copyright (C) 1997-2005 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- --
@@ -120,15 +120,13 @@ pragma Preelaborate (Spitbol);
    --  Equivalent to Character'Val (Num)
 
    function Lpad
-     (Str  : VString;
-      Len  : Natural;
-      Pad  : Character := ' ')
-      return VString;
+     (Str : VString;
+      Len : Natural;
+      Pad : Character := ' ') return VString;
    function Lpad
-     (Str  : String;
-      Len  : Natural;
-      Pad  : Character := ' ')
-      return VString;
+     (Str : String;
+      Len : Natural;
+      Pad : Character := ' ') return VString;
    --  If the length of Str is greater than or equal to Len, then Str is
    --  returned unchanged. Otherwise, The value returned is obtained by
    --  concatenating Length (Str) - Len instances of the Pad character to
@@ -151,15 +149,13 @@ pragma Preelaborate (Spitbol);
    --  result overwrites the input argument Str.
 
    function Rpad
-     (Str  : VString;
-      Len  : Natural;
-      Pad  : Character := ' ')
-      return VString;
+     (Str : VString;
+      Len : Natural;
+      Pad : Character := ' ') return VString;
    function Rpad
-     (Str  : String;
-      Len  : Natural;
-      Pad  : Character := ' ')
-      return VString;
+     (Str : String;
+      Len : Natural;
+      Pad : Character := ' ') return VString;
    --  If the length of Str is greater than or equal to Len, then Str is
    --  returned unchanged. Otherwise, The value returned is obtained by
    --  concatenating Length (Str) - Len instances of the Pad character to
@@ -178,13 +174,11 @@ pragma Preelaborate (Spitbol);
    function Substr
      (Str   : VString;
       Start : Positive;
-      Len   : Natural)
-      return  VString;
+      Len   : Natural) return  VString;
    function Substr
      (Str   : String;
       Start : Positive;
-      Len   : Natural)
-      return  VString;
+      Len   : Natural) return  VString;
    --  Returns the substring starting at the given character position (which
    --  is always counted from the start of the string, regardless of bounds,
    --  e.g. 2 means starting with the second character of the string), and
Index: a-swunau.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-swunau.ads,v
retrieving revision 1.1
diff -u -p -r1.1 a-swunau.ads
--- a-swunau.ads	9 Feb 2005 11:14:41 -0000	1.1
+++ a-swunau.ads	15 Mar 2005 13:54:57 -0000
@@ -39,20 +39,22 @@
 package Ada.Strings.Wide_Unbounded.Aux is
 pragma Preelaborate (Aux);
 
-   function Get_Wide_String
-     (U : Unbounded_Wide_String) return Wide_String_Access;
+   procedure Get_Wide_String
+     (U : Unbounded_Wide_String;
+      S : out Wide_String_Access;
+      L : out Natural);
    pragma Inline (Get_Wide_String);
-   --  This function returns the internal string pointer used in the
-   --  representation of an unbounded string. There is no copy involved,
-   --  so the value obtained references the same string as the original
-   --  unbounded string. The characters of this string may not be modified
-   --  via the returned pointer, and are valid only as long as the original
-   --  unbounded string is not modified. Violating either of these two
-   --  rules results in erroneous execution.
+   --  This procedure returns the internal string pointer used in the
+   --  representation of an unbounded string as well as the actual current
+   --  length (which may be less than S.all'Length because in general there
+   --  can be extra space assigned). The characters of this string may be
+   --  not be modified via the returned pointer,  and are valid only as
+   --  long as the original unbounded string is not accessed or modified.
    --
-   --  This function is much more efficient than the use of To_Wide_String
+   --  This procedure is much more efficient than the use of To_Wide_String
    --  since it avoids the need to copy the string. The lower bound of the
-   --  referenced string returned by this call is always one.
+   --  referenced string returned by this call is always one, so the actual
+   --  string data is always accessible as S (1 .. L).
 
    procedure Set_Wide_String
      (UP : in out Unbounded_Wide_String;
Index: a-swunau.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-swunau.adb,v
retrieving revision 1.1
diff -u -p -r1.1 a-swunau.adb
--- a-swunau.adb	9 Feb 2005 11:14:41 -0000	1.1
+++ a-swunau.adb	15 Mar 2005 13:54:57 -0000
@@ -37,33 +37,14 @@ package body Ada.Strings.Wide_Unbounded.
    -- Get_Wide_String --
    ---------------------
 
-   function Get_Wide_String
-     (U : Unbounded_Wide_String) return Wide_String_Access
+   procedure Get_Wide_String
+     (U : Unbounded_Wide_String;
+      S : out Wide_String_Access;
+      L : out Natural)
    is
    begin
-      if U.Last = U.Reference'Length then
-         return U.Reference;
-
-      else
-         declare
-            type Unbounded_Wide_String_Access is
-              access all Unbounded_Wide_String;
-
-            U_Ptr : constant Unbounded_Wide_String_Access :=
-                      U'Unrestricted_Access;
-            --  Unbounded_Wide_String is a controlled type which is always
-            --  passed by copy it is always safe to take the pointer to such
-            --  object here. This pointer is used to set the U.Reference value
-            --  which would not be possible otherwise as U is read-only.
-
-            Old : Wide_String_Access := U.Reference;
-
-         begin
-            U_Ptr.Reference := new Wide_String'(U.Reference (1 .. U.Last));
-            Free (Old);
-            return U.Reference;
-         end;
-      end if;
+      S := U.Reference;
+      L := U.Last;
    end Get_Wide_String;
 
    ---------------------
@@ -75,20 +56,13 @@ package body Ada.Strings.Wide_Unbounded.
       S  : Wide_String)
    is
    begin
-      if UP.Last = S'Length then
-         UP.Reference.all := S;
-
-      else
-         declare
-            subtype String_1 is Wide_String (1 .. S'Length);
-            Tmp : Wide_String_Access;
-         begin
-            Tmp := new Wide_String'(String_1 (S));
-            Finalize (UP);
-            UP.Reference := Tmp;
-            UP.Last := UP.Reference'Length;
-         end;
+      if S'Length > UP.Last then
+         Finalize (UP);
+         UP.Reference := new Wide_String (1 .. S'Length);
       end if;
+
+      UP.Reference (1 .. S'Length) := S;
+      UP.Last := S'Length;
    end Set_Wide_String;
 
    procedure Set_Wide_String
Index: a-szunau.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-szunau.ads,v
retrieving revision 1.1
diff -u -p -r1.1 a-szunau.ads
--- a-szunau.ads	9 Feb 2005 11:14:41 -0000	1.1
+++ a-szunau.ads	15 Mar 2005 13:54:57 -0000
@@ -39,20 +39,22 @@
 package Ada.Strings.Wide_Wide_Unbounded.Aux is
 pragma Preelaborate (Aux);
 
-   function Get_Wide_Wide_String
-     (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access;
+   procedure Get_Wide_Wide_String
+     (U : Unbounded_Wide_Wide_String;
+      S : out Wide_Wide_String_Access;
+      L : out Natural);
    pragma Inline (Get_Wide_Wide_String);
-   --  This function returns the internal string pointer used in the
-   --  representation of an unbounded string. There is no copy involved,
-   --  so the value obtained references the same string as the original
-   --  unbounded string. The characters of this string may not be modified
-   --  via the returned pointer, and are valid only as long as the original
-   --  unbounded string is not modified. Violating either of these two
-   --  rules results in erroneous execution.
+   --  This procedure returns the internal string pointer used in the
+   --  representation of an unbounded string as well as the actual current
+   --  length (which may be less than S.all'Length because in general there
+   --  can be extra space assigned). The characters of this string may be
+   --  not be modified via the returned pointer,  and are valid only as
+   --  long as the original unbounded string is not accessed or modified.
    --
-   --  This function is much more efficient than the use of To_Wide_Wide_String
+   --  This procedure is more efficient than the use of To_Wide_Wide_String
    --  since it avoids the need to copy the string. The lower bound of the
-   --  referenced string returned by this call is always one.
+   --  referenced string returned by this call is always one, so the actual
+   --  string data is always accessible as S (1 .. L).
 
    procedure Set_Wide_Wide_String
      (UP : in out Unbounded_Wide_Wide_String;
Index: a-szunau.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/a-szunau.adb,v
retrieving revision 1.1
diff -u -p -r1.1 a-szunau.adb
--- a-szunau.adb	9 Feb 2005 11:14:41 -0000	1.1
+++ a-szunau.adb	15 Mar 2005 13:54:57 -0000
@@ -33,63 +33,36 @@
 
 package body Ada.Strings.Wide_Wide_Unbounded.Aux is
 
-   --------------------------
+   --------------------
    -- Get_Wide_Wide_String --
-   --------------------------
+   ---------------------
 
-   function Get_Wide_Wide_String
-     (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access
+   procedure Get_Wide_Wide_String
+     (U : Unbounded_Wide_Wide_String;
+      S : out Wide_Wide_String_Access;
+      L : out Natural)
    is
    begin
-      if U.Last = U.Reference'Length then
-         return U.Reference;
-
-      else
-         declare
-            type Unbounded_Wide_Wide_String_Access is
-              access all Unbounded_Wide_Wide_String;
-
-            U_Ptr : constant Unbounded_Wide_Wide_String_Access :=
-                      U'Unrestricted_Access;
-            --  Unbounded_Wide_Wide_String is a controlled type which is always
-            --  passed by copy it is always safe to take the pointer to such
-            --  object here. This pointer is used to set the U.Reference value
-            --  which would not be possible otherwise as U is read-only.
-
-            Old : Wide_Wide_String_Access := U.Reference;
-
-         begin
-            U_Ptr.Reference :=
-              new Wide_Wide_String'(U.Reference (1 .. U.Last));
-            Free (Old);
-            return U.Reference;
-         end;
-      end if;
+      S := U.Reference;
+      L := U.Last;
    end Get_Wide_Wide_String;
 
-   --------------------------
+   ---------------------
    -- Set_Wide_Wide_String --
-   --------------------------
+   ---------------------
 
    procedure Set_Wide_Wide_String
      (UP : in out Unbounded_Wide_Wide_String;
       S  : Wide_Wide_String)
    is
    begin
-      if UP.Last = S'Length then
-         UP.Reference.all := S;
-
-      else
-         declare
-            subtype String_1 is Wide_Wide_String (1 .. S'Length);
-            Tmp : Wide_Wide_String_Access;
-         begin
-            Tmp := new Wide_Wide_String'(String_1 (S));
-            Finalize (UP);
-            UP.Reference := Tmp;
-            UP.Last := UP.Reference'Length;
-         end;
+      if S'Length > UP.Last then
+         Finalize (UP);
+         UP.Reference := new Wide_Wide_String (1 .. S'Length);
       end if;
+
+      UP.Reference (1 .. S'Length) := S;
+      UP.Last := S'Length;
    end Set_Wide_Wide_String;
 
    procedure Set_Wide_Wide_String


More information about the Gcc-patches mailing list