]>
Commit | Line | Data |
---|---|---|
cacbc350 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S Y S T E M . V A L _ W C H A R -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
cacbc350 RK |
10 | -- -- |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
cacbc350 RK |
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 -- | |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
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. -- | |
21 | -- -- | |
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/>. -- | |
cacbc350 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
cacbc350 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
82c80734 | 32 | with Interfaces; use Interfaces; |
cacbc350 | 33 | with System.Val_Util; use System.Val_Util; |
c99e6969 RD |
34 | with System.WCh_Cnv; use System.WCh_Cnv; |
35 | with System.WCh_Con; use System.WCh_Con; | |
cacbc350 RK |
36 | |
37 | package body System.Val_WChar is | |
38 | ||
39 | -------------------------- | |
40 | -- Value_Wide_Character -- | |
41 | -------------------------- | |
42 | ||
43 | function Value_Wide_Character | |
c99e6969 RD |
44 | (Str : String; |
45 | EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character | |
82c80734 | 46 | is |
c99e6969 RD |
47 | WC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str, EM); |
48 | WV : constant Unsigned_32 := Wide_Wide_Character'Pos (WC); | |
82c80734 | 49 | begin |
c99e6969 | 50 | if WV > 16#FFFF# then |
37ae92c4 | 51 | Bad_Value (Str); |
82c80734 | 52 | else |
c99e6969 | 53 | return Wide_Character'Val (WV); |
82c80734 RD |
54 | end if; |
55 | end Value_Wide_Character; | |
56 | ||
57 | ------------------------------- | |
58 | -- Value_Wide_Wide_Character -- | |
59 | ------------------------------- | |
60 | ||
61 | function Value_Wide_Wide_Character | |
c99e6969 RD |
62 | (Str : String; |
63 | EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character | |
cacbc350 RK |
64 | is |
65 | F : Natural; | |
66 | L : Natural; | |
67 | S : String (Str'Range) := Str; | |
68 | ||
69 | begin | |
70 | Normalize_String (S, F, L); | |
71 | ||
72 | -- Character literal case | |
73 | ||
74 | if S (F) = ''' and then S (L) = ''' then | |
75 | ||
c99e6969 RD |
76 | -- Must be at least three characters |
77 | ||
78 | if L - F < 2 then | |
37ae92c4 | 79 | Bad_Value (Str); |
c99e6969 | 80 | |
cacbc350 RK |
81 | -- If just three characters, simple character case |
82 | ||
c99e6969 | 83 | elsif L - F = 2 then |
82c80734 | 84 | return Wide_Wide_Character'Val (Character'Pos (S (F + 1))); |
cacbc350 | 85 | |
c99e6969 | 86 | -- Only other possibility for quoted string is wide char sequence |
cacbc350 RK |
87 | |
88 | else | |
c99e6969 RD |
89 | declare |
90 | P : Natural; | |
91 | W : Wide_Wide_Character; | |
92 | ||
93 | function In_Char return Character; | |
94 | -- Function for instantiations of Char_Sequence_To_UTF_32 | |
95 | ||
96 | ------------- | |
97 | -- In_Char -- | |
98 | ------------- | |
99 | ||
100 | function In_Char return Character is | |
101 | begin | |
102 | P := P + 1; | |
103 | ||
104 | if P = Str'Last then | |
37ae92c4 | 105 | Bad_Value (Str); |
c99e6969 RD |
106 | end if; |
107 | ||
108 | return Str (P); | |
109 | end In_Char; | |
110 | ||
111 | function UTF_32 is | |
112 | new Char_Sequence_To_UTF_32 (In_Char); | |
113 | ||
114 | begin | |
115 | P := F + 1; | |
116 | ||
117 | -- Brackets encoding | |
118 | ||
119 | if S (F + 1) = '[' then | |
120 | W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets)); | |
c99e6969 RD |
121 | else |
122 | W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM)); | |
123 | end if; | |
124 | ||
125 | if P /= L - 1 then | |
37ae92c4 | 126 | Bad_Value (Str); |
c99e6969 RD |
127 | end if; |
128 | ||
129 | return W; | |
130 | end; | |
cacbc350 RK |
131 | end if; |
132 | ||
edd63e9b | 133 | -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases |
cacbc350 | 134 | |
c99e6969 RD |
135 | elsif Str'Length = 12 |
136 | and then Str (Str'First .. Str'First + 3) = "Hex_" | |
137 | then | |
edd63e9b ES |
138 | declare |
139 | W : Unsigned_32 := 0; | |
cacbc350 | 140 | |
edd63e9b | 141 | begin |
c99e6969 | 142 | for J in Str'First + 4 .. Str'First + 11 loop |
edd63e9b | 143 | W := W * 16 + Character'Pos (Str (J)); |
cacbc350 | 144 | |
edd63e9b ES |
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; | |
151 | else | |
37ae92c4 | 152 | Bad_Value (Str); |
edd63e9b ES |
153 | end if; |
154 | end loop; | |
cacbc350 | 155 | |
edd63e9b | 156 | if W > 16#7FFF_FFFF# then |
37ae92c4 | 157 | Bad_Value (Str); |
edd63e9b ES |
158 | else |
159 | return Wide_Wide_Character'Val (W); | |
cacbc350 | 160 | end if; |
edd63e9b | 161 | end; |
cacbc350 | 162 | |
edd63e9b | 163 | -- Otherwise must be one of the special names for Character |
cacbc350 | 164 | |
edd63e9b ES |
165 | else |
166 | return | |
167 | Wide_Wide_Character'Val (Character'Pos (Character'Value (Str))); | |
cacbc350 | 168 | end if; |
c99e6969 RD |
169 | |
170 | exception | |
171 | when Constraint_Error => | |
37ae92c4 | 172 | Bad_Value (Str); |
82c80734 | 173 | end Value_Wide_Wide_Character; |
cacbc350 RK |
174 | |
175 | end System.Val_WChar; |