1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2007, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System
.WCh_Cnv
; use System
.WCh_Cnv
;
36 with GNAT
.UTF_32_Spelling_Checker
;
38 package body Namet
.Sp
is
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
44 procedure Get_Name_String_UTF_32
46 Result
: out UTF_32_String
;
47 Length
: out Natural);
48 -- This procedure is similar to Get_Decoded_Name except that the output
49 -- is stored in the given Result array as single codes, so in particular
50 -- any Uhh, Whhhh, or WWhhhhhhhh sequences are decoded to appear as a
51 -- single value in the output. This call does not affect the contents of
52 -- either Name_Buffer or Name_Len. The result is in Result (1 .. Length).
53 -- The caller must ensure that the result buffer is long enough.
55 ----------------------------
56 -- Get_Name_String_UTF_32 --
57 ----------------------------
59 procedure Get_Name_String_UTF_32
61 Result
: out UTF_32_String
;
64 pragma Assert
(Result
'First = 1);
66 SPtr
: Int
:= Name_Entries
.Table
(Id
).Name_Chars_Index
+ 1;
67 -- Index through characters of name in Name_Chars table. Initial value
68 -- points to first character of the name.
70 SLen
: constant Nat
:= Nat
(Name_Entries
.Table
(Id
).Name_Len
);
73 SLast
: constant Int
:= SPtr
+ SLen
- 1;
74 -- Last index in Name_Chars table for name
77 -- Current character from Name_Chars table
79 procedure Store_Hex
(N
: Natural);
80 -- Read and store next N characters starting at SPtr and store result
81 -- in next character of Result. Update SPtr past characters read.
87 procedure Store_Hex
(N
: Natural) is
94 C
:= Name_Chars
.Table
(SPtr
);
97 if C
in '0' .. '9' then
98 T
:= 16 * T
+ Character'Pos (C
) - Character'Pos ('0');
100 pragma Assert
(C
in 'a' .. 'f');
102 T
:= 16 * T
+ Character'Pos (C
) - (Character'Pos ('a') - 10);
106 Length
:= Length
+ 1;
107 pragma Assert
(Length
<= Result
'Length);
108 Result
(Length
) := T
;
111 -- Start of processing for Get_Name_String_UTF_32
115 while SPtr
<= SLast
loop
116 C
:= Name_Chars
.Table
(SPtr
);
121 and then SPtr
<= SLast
- 2
122 and then Name_Chars
.Table
(SPtr
+ 1) not in 'A' .. 'Z'
130 and then SPtr
<= SLast
- 4
131 and then Name_Chars
.Table
(SPtr
+ 1) not in 'A' .. 'Z'
136 -- WWhhhhhhhh encoding
139 and then SPtr
<= SLast
- 8
140 and then Name_Chars
.Table
(SPtr
+ 1) = 'W'
145 -- Q encoding (character literal)
147 elsif C
= 'Q' and then SPtr
< SLast
then
149 -- Put apostrophes around character
151 pragma Assert
(Length
<= Result
'Last - 3);
152 Result
(Length
+ 1) := UTF_32_Code
'Val (Character'Pos ('''));
153 Result
(Length
+ 2) :=
154 UTF_32_Code
(Get_Char_Code
(Name_Chars
.Table
(SPtr
+ 1)));
155 Result
(Length
+ 3) := UTF_32_Code
'Val (Character'Pos ('''));
157 Length
:= Length
+ 3;
163 Length
:= Length
+ 1;
164 pragma Assert
(Length
<= Result
'Last);
165 Result
(Length
) := UTF_32_Code
(Get_Char_Code
(C
));
168 end Get_Name_String_UTF_32
;
170 ------------------------
171 -- Is_Bad_Spelling_Of --
172 ------------------------
174 function Is_Bad_Spelling_Of
(Found
, Expect
: Name_Id
) return Boolean is
175 FL
: constant Natural := Natural (Length_Of_Name
(Found
));
176 EL
: constant Natural := Natural (Length_Of_Name
(Expect
));
177 -- Length of input names
179 FB
: UTF_32_String
(1 .. 2 * FL
);
180 EB
: UTF_32_String
(1 .. 2 * EL
);
181 -- Buffers for results, a factor of 2 is more than enough, the only
182 -- sequence which expands is Q (character literal) by 1.5 times.
186 -- Length of decoded names
189 Get_Name_String_UTF_32
(Found
, FB
, FBL
);
190 Get_Name_String_UTF_32
(Expect
, EB
, EBL
);
192 GNAT
.UTF_32_Spelling_Checker
.Is_Bad_Spelling_Of
193 (FB
(1 .. FBL
), EB
(1 .. EBL
));
194 end Is_Bad_Spelling_Of
;