[Ada] Segmentation_Fault with Integer'Wide_Wide_Value

This patch updates the routines which produce Wide_String and Wide_Wide_String
from a String to construct a result of the proper maximum size which is later
sliced.

2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* libgnat/s-wchwts.adb (Wide_String_To_String): Use the appropriate
	longest sequence factor. Code clean up.
	(Wide_Wide_String_To_String): Use the appropriate longest sequence
	factor.  Code clean up.

gcc/testsuite/

	* gnat.dg/wide_wide_value1.adb: New testcase.

From-SVN: r262713

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 51b73f8bf2377c5ab7bfb74ca8a7c0a6cb3599f7..a782582543e5c2a54d2cd36afa8e822d7ac4f4c6 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * libgnat/s-wchwts.adb (Wide_String_To_String): Use the appropriate
+       longest sequence factor. Code clean up.
+       (Wide_Wide_String_To_String): Use the appropriate longest sequence
+       factor.  Code clean up.
+
 2018-07-16  Javier Miranda  <miranda@adacore.com>
 
        * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Report an error

diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb
index c5556abba6866fbaee97e039e23713afaecceb03..4eed382bbb8789f3b2979e881ea4102eeff0310b 100644 (file)
--- a/gcc/ada/libgnat/s-wchwts.adb
+++ b/gcc/ada/libgnat/s-wchwts.adb
@@ -86,16 +86,23 @@ package body System.WCh_WtS is
      (S  : Wide_String;
       EM : WC_Encoding_Method) return String
    is
-      R  : String (S'First .. S'First + 5 * S'Length); -- worst case length
-      RP : Natural;
+      Max_Chars : constant Natural := WC_Longest_Sequences (EM);
+
+      Result     : String (S'First .. S'First + Max_Chars * S'Length);
+      Result_Idx : Natural;
 
    begin
-      RP := R'First - 1;
-      for SP in S'Range loop
-         Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM);
+      Result_Idx := Result'First - 1;
+
+      for S_Idx in S'Range loop
+         Store_UTF_32_Character
+           (U  => Wide_Character'Pos (S (S_Idx)),
+            S  => Result,
+            P  => Result_Idx,
+            EM => EM);
       end loop;
 
-      return R (R'First .. RP);
+      return Result (Result'First .. Result_Idx);
    end Wide_String_To_String;
 
    --------------------------------
@@ -106,17 +113,23 @@ package body System.WCh_WtS is
      (S  : Wide_Wide_String;
       EM : WC_Encoding_Method) return String
    is
-      R  : String (S'First .. S'First + 7 * S'Length); -- worst case length
-      RP : Natural;
+      Max_Chars : constant Natural := WC_Longest_Sequences (EM);
 
-   begin
-      RP := R'First - 1;
+      Result     : String (S'First .. S'First + Max_Chars * S'Length);
+      Result_Idx : Natural;
 
-      for SP in S'Range loop
-         Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM);
+   begin
+      Result_Idx := Result'First - 1;
+
+      for S_Idx in S'Range loop
+         Store_UTF_32_Character
+           (U  => Wide_Wide_Character'Pos (S (S_Idx)),
+            S  => Result,
+            P  => Result_Idx,
+            EM => EM);
       end loop;
 
-      return R (R'First .. RP);
+      return Result (Result'First .. Result_Idx);
    end Wide_Wide_String_To_String;
 
 end System.WCh_WtS;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index df006b691194a814010085ec9af61f2a1822e1fc..506bdf836fba1dac115f375e1d8641dcfbef17f8 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/wide_wide_value1.adb: New testcase.
+
 2018-07-16  Javier Miranda  <miranda@adacore.com>
 
        * gnat.dg/bit_order1.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/wide_wide_value1.adb b/gcc/testsuite/gnat.dg/wide_wide_value1.adb
new file mode 100644 (file)
index 0000000..28b9222
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/wide_wide_value1.adb
@@ -0,0 +1,60 @@
+--  { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Wide_Wide_Value1 is
+begin
+   begin
+      declare
+         Str : constant Wide_Wide_String :=
+                 Wide_Wide_Character'Val (16#00000411#) &
+                 Wide_Wide_Character'Val (16#0000043e#) &
+                 Wide_Wide_Character'Val (16#00000434#) &
+                 Wide_Wide_Character'Val (16#00000430#) &
+                 Wide_Wide_Character'Val (16#00000443#) &
+                 Wide_Wide_Character'Val (16#00000431#) &
+                 Wide_Wide_Character'Val (16#00000430#) &
+                 Wide_Wide_Character'Val (16#00000435#) &
+                 Wide_Wide_Character'Val (16#00000432#) &
+                 Wide_Wide_Character'Val (16#00000416#) &
+                 Wide_Wide_Character'Val (16#00000443#) &
+                 Wide_Wide_Character'Val (16#0000043c#) &
+                 Wide_Wide_Character'Val (16#00000430#) &
+                 Wide_Wide_Character'Val (16#00000442#) &
+                 Wide_Wide_Character'Val (16#0000041c#) &
+                 Wide_Wide_Character'Val (16#00000430#) &
+                 Wide_Wide_Character'Val (16#00000440#) &
+                 Wide_Wide_Character'Val (16#00000430#) &
+                 Wide_Wide_Character'Val (16#00000442#) &
+                 Wide_Wide_Character'Val (16#0000043e#) &
+                 Wide_Wide_Character'Val (16#00000432#) &
+                 Wide_Wide_Character'Val (16#00000438#) &
+                 Wide_Wide_Character'Val (16#00000447#);
+
+         Val : constant Integer := Integer'Wide_Wide_Value (Str);
+      begin
+         Put_Line ("ERROR: 1: Constraint_Error not raised");
+      end;
+   exception
+      when Constraint_Error =>
+         null;
+      when others =>
+         Put_Line ("ERROR: 1: unexpected exception");
+   end;
+
+   begin
+      declare
+         Str : Wide_Wide_String (1 .. 128) :=
+                 (others => Wide_Wide_Character'Val (16#0FFFFFFF#));
+
+         Val : constant Integer := Integer'Wide_Wide_Value (Str);
+      begin
+         Put_Line ("ERROR: 1: Constraint_Error not raised");
+      end;
+   exception
+      when Constraint_Error =>
+         null;
+      when others =>
+         Put_Line ("ERROR: 1: unexpected exception");
+   end;
+end Wide_Wide_Value1;