exp_imgv.adb (Expand_Image_Attribute): For Wide_[Wide_]Character cases...

2006-10-31  Robert Dewar  <dewar@adacore.com>

	* exp_imgv.adb (Expand_Image_Attribute): For Wide_[Wide_]Character
	cases, pass the encoding method, since it is now required by the run
	time.

	* s-valwch.ads, s-valwch.adb (Value_Wide_Wide_Character): Avoid
	assumption that Str'First = 1.
	(Value_Wide_Character): Takes EM (encoding method) parameter and passes
	it on to the Value_Wide_Wide_Character call.
	(Value_Wide_Wide_Character): Takes EM (encoding method) parameter and
	properly handles a string of the form quote-encoded_wide_char-quote.

	* s-wchcnv.adb: Minor reformatting

From-SVN: r118266

gcc/ada/exp_imgv.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2001-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2006, 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- --
@@ -424,7 +424,7 @@ package body Exp_Imgv is
 
    --    btyp (Value_xx (X))
 
-   --  where btyp is he base type of the prefix, and
+   --  where btyp is he base type of the prefix
 
    --    For types whose root type is Character
    --      xx = Character
@@ -453,6 +453,12 @@ package body Exp_Imgv is
    --    For floating-point types and ordinary fixed-point types
    --      xx = Real
 
+   --  For Wide_[Wide_]Character types, typ'Value (X) expands into:
+
+   --    btyp (Value_xx (X, EM))
+
+   --  where btyp is the base type of the prefix, and EM is the encoding method
+
    --  For decimal types with size <= Integer'Size, typ'Value (X)
    --  expands into
 
@@ -498,9 +504,17 @@ package body Exp_Imgv is
       elsif Rtyp = Standard_Wide_Character then
          Vid := RE_Value_Wide_Character;
 
+         Append_To (Args,
+           Make_Integer_Literal (Loc,
+             Intval => Int (Wide_Character_Encoding_Method)));
+
       elsif Rtyp = Standard_Wide_Wide_Character then
          Vid := RE_Value_Wide_Wide_Character;
 
+         Append_To (Args,
+           Make_Integer_Literal (Loc,
+             Intval => Int (Wide_Character_Encoding_Method)));
+
       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
         or else Rtyp = Base_Type (Standard_Short_Integer)
         or else Rtyp = Base_Type (Standard_Integer)

gcc/ada/s-valwch.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -33,6 +33,8 @@
 
 with Interfaces;      use Interfaces;
 with System.Val_Util; use System.Val_Util;
+with System.WCh_Cnv;  use System.WCh_Cnv;
+with System.WCh_Con;  use System.WCh_Con;
 
 package body System.Val_WChar is
 
@@ -41,16 +43,17 @@ package body System.Val_WChar is
    --------------------------
 
    function Value_Wide_Character
-      (Str : String) return Wide_Character
+     (Str : String;
+      EM  : System.WCh_Con.WC_Encoding_Method) return Wide_Character
    is
-      WWC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str);
-      WWV : constant Unsigned_32         := Wide_Wide_Character'Pos (WWC);
+      WC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str, EM);
+      WV : constant Unsigned_32         := Wide_Wide_Character'Pos (WC);
    begin
-      if WWV > 16#FFFF# then
+      if WV > 16#FFFF# then
          raise Constraint_Error
            with "out of range character for Value attribute";
       else
-         return Wide_Character'Val (WWV);
+         return Wide_Character'Val (WV);
       end if;
    end Value_Wide_Character;
 
@@ -59,7 +62,8 @@ package body System.Val_WChar is
    -------------------------------
 
    function Value_Wide_Wide_Character
-      (Str : String) return Wide_Wide_Character
+     (Str : String;
+      EM  : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character
    is
       F : Natural;
       L : Natural;
@@ -72,25 +76,74 @@ package body System.Val_WChar is
 
       if S (F) = ''' and then S (L) = ''' then
 
+         --  Must be at least three characters
+
+         if L - F < 2 then
+            raise Constraint_Error;
+
          --  If just three characters, simple character case
 
-         if L - F = 2 then
+         elsif L - F = 2 then
             return Wide_Wide_Character'Val (Character'Pos (S (F + 1)));
 
-            --  Otherwise something is very wrong
+         --  Only other possibility for quoted string is wide char sequence
 
          else
-            raise Constraint_Error with "invalid string for Value attribute";
+            declare
+               P : Natural;
+               W : Wide_Wide_Character;
+
+               function In_Char return Character;
+               --  Function for instantiations of Char_Sequence_To_UTF_32
+
+               -------------
+               -- In_Char --
+               -------------
+
+               function In_Char return Character is
+               begin
+                  P := P + 1;
+
+                  if P = Str'Last then
+                     raise Constraint_Error;
+                  end if;
+
+                  return Str (P);
+               end In_Char;
+
+               function UTF_32 is
+                 new Char_Sequence_To_UTF_32 (In_Char);
+
+            begin
+               P := F + 1;
+
+               --  Brackets encoding
+
+               if S (F + 1) = '[' then
+                  W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets));
+
+               else
+                  W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM));
+               end if;
+
+               if P /= L - 1 then
+                  raise Constraint_Error;
+               end if;
+
+               return W;
+            end;
          end if;
 
       --  Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases
 
-      elsif Str'Length = 12 and then Str (1 .. 4) = "Hex_" then
+      elsif Str'Length = 12
+        and then Str (Str'First .. Str'First + 3) = "Hex_"
+      then
          declare
             W : Unsigned_32 := 0;
 
          begin
-            for J in 5 .. 12 loop
+            for J in Str'First + 4 .. Str'First + 11 loop
                W := W * 16 + Character'Pos (Str (J));
 
                if Str (J) in '0' .. '9' then
@@ -100,14 +153,12 @@ package body System.Val_WChar is
                elsif Str (J) in 'a' .. 'f' then
                   W := W - Character'Pos ('a') + 10;
                else
-                  raise Constraint_Error
-                    with "illegal hex character for Value attribute";
+                  raise Constraint_Error;
                end if;
             end loop;
 
             if W > 16#7FFF_FFFF# then
-               raise Constraint_Error
-                 with "out of range value for Value attribute";
+               raise Constraint_Error;
             else
                return Wide_Wide_Character'Val (W);
             end if;
@@ -119,6 +170,10 @@ package body System.Val_WChar is
          return
            Wide_Wide_Character'Val (Character'Pos (Character'Value (Str)));
       end if;
+
+   exception
+      when Constraint_Error =>
+         raise Constraint_Error with "invalid string for value attribute";
    end Value_Wide_Wide_Character;
 
 end System.Val_WChar;

gcc/ada/s-valwch.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -33,15 +33,23 @@
 
 --  Processing for Wide_[Wide_]Value attribute
 
+with System.WCh_Con;
+
 package System.Val_WChar is
    pragma Pure;
 
    function Value_Wide_Character
-      (Str : String) return Wide_Character;
-   --  Computes Wide_Character'Value (Str)
+     (Str : String;
+      EM  : System.WCh_Con.WC_Encoding_Method) return Wide_Character;
+   --  Computes Wide_Character'Value (Str). The parameter EM is the encoding
+   --  method used for any Wide_Character sequences in Str. Note that brackets
+   --  notation is always permitted.
 
    function Value_Wide_Wide_Character
-      (Str : String) return Wide_Wide_Character;
-   --  Computes Wide_Character'Value (Str)
+     (Str : String;
+      EM  : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character;
+   --  Computes Wide_Character'Value (Str). The parameter EM is the encoding
+   --  method used for any wide_character sequences in Str. Note that brackets
+   --  notation is always permitted.
 
 end System.Val_WChar;

gcc/ada/s-wchcnv.adb

@@ -46,8 +46,8 @@ package body System.WCh_Cnv is
    -----------------------------
 
    function Char_Sequence_To_UTF_32
-     (C       : Character;
-      EM      : WC_Encoding_Method) return UTF_32_Code
+     (C  : Character;
+      EM : WC_Encoding_Method) return UTF_32_Code
    is
       B1 : Unsigned_32;
       C1 : Character;