OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/13470 (64bits Ada bootstrap failure:xnmake etc. crash generating nmake.adb etc.) 

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

From-SVN: r96488
This commit is contained in:
Robert Dewar 2005-03-15 16:53:10 +01:00 committed by Arnaud Charlet
parent 798a90555d
commit 2f388d2db6
10 changed files with 500 additions and 426 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
gcc/ada/a-stunau.adb
View File

@ -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 is
-- 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 is
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

23
gcc/ada/a-stunau.ads
View File

@ -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);

50
gcc/ada/a-swunau.adb
View File

@ -37,33 +37,14 @@ package body Ada.Strings.Wide_Unbounded.Aux is
-- 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.Aux is
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

24
gcc/ada/a-swunau.ads
View File

@ -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;

59
gcc/ada/a-szunau.adb
View File

@ -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

24
gcc/ada/a-szunau.ads
View File

@ -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;

510
gcc/ada/g-spipat.adb
View File

File diff suppressed because it is too large Load Diff

29
gcc/ada/g-spipat.ads
View File

@ -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;

118
gcc/ada/g-spitbo.adb
View File

@ -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
Get_String (Str, S, L);
if Start > L then
raise Index_Error;
elsif Start + Len - 1 > Length (Str) then
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

36
gcc/ada/g-spitbo.ads
View File

@ -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