1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V A L _ W C H A R --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Interfaces
; use Interfaces
;
33 with System
.Val_Util
; use System
.Val_Util
;
34 with System
.WCh_Cnv
; use System
.WCh_Cnv
;
35 with System
.WCh_Con
; use System
.WCh_Con
;
37 package body System
.Val_WChar
is
39 --------------------------
40 -- Value_Wide_Character --
41 --------------------------
43 function Value_Wide_Character
45 EM
: System
.WCh_Con
.WC_Encoding_Method
) return Wide_Character
47 WC
: constant Wide_Wide_Character
:= Value_Wide_Wide_Character
(Str
, EM
);
48 WV
: constant Unsigned_32
:= Wide_Wide_Character
'Pos (WC
);
53 return Wide_Character'Val (WV
);
55 end Value_Wide_Character
;
57 -------------------------------
58 -- Value_Wide_Wide_Character --
59 -------------------------------
61 function Value_Wide_Wide_Character
63 EM
: System
.WCh_Con
.WC_Encoding_Method
) return Wide_Wide_Character
67 S
: String (Str
'Range) := Str
;
70 Normalize_String
(S
, F
, L
);
72 -- Character literal case
74 if S
(F
) = ''' and then S
(L
) = ''' then
76 -- Must be at least three characters
81 -- If just three characters, simple character case
84 return Wide_Wide_Character
'Val (Character'Pos (S
(F
+ 1)));
86 -- Only other possibility for quoted string is wide char sequence
91 W
: Wide_Wide_Character
;
93 function In_Char
return Character;
94 -- Function for instantiations of Char_Sequence_To_UTF_32
100 function In_Char
return Character is
112 new Char_Sequence_To_UTF_32
(In_Char
);
119 if S
(F
+ 1) = '[' then
120 W
:= Wide_Wide_Character
'Val (UTF_32
('[', WCEM_Brackets
));
122 W
:= Wide_Wide_Character
'Val (UTF_32
(S
(F
+ 1), EM
));
133 -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases
135 elsif Str
'Length = 12
136 and then Str
(Str
'First .. Str
'First + 3) = "Hex_"
139 W
: Unsigned_32
:= 0;
142 for J
in Str
'First + 4 .. Str
'First + 11 loop
143 W
:= W
* 16 + Character'Pos (Str
(J
));
145 if Str
(J
) in '0' .. '9' then
146 W
:= W
- Character'Pos ('0');
147 elsif Str
(J
) in 'A' .. 'F' then
148 W
:= W
- Character'Pos ('A') + 10;
149 elsif Str
(J
) in 'a' .. 'f' then
150 W
:= W
- Character'Pos ('a') + 10;
156 if W
> 16#
7FFF_FFFF#
then
159 return Wide_Wide_Character
'Val (W
);
163 -- Otherwise must be one of the special names for Character
167 Wide_Wide_Character
'Val (Character'Pos (Character'Value (Str
)));
171 when Constraint_Error
=>
173 end Value_Wide_Wide_Character
;
175 end System
.Val_WChar
;