1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240 | --
-- Copyright (C) 2014-2022, AdaCore
-- SPDX-License-Identifier: Apache-2.0
--
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body Gpr_Parser_Support.Names is
-------------------
-- Is_Valid_Name --
-------------------
function Is_Valid_Name
(Name : Text_Type;
Casing : Casing_Convention := Camel_With_Underscores) return Boolean
is
subtype Alphanumerical is Character_Type with Static_Predicate =>
Alphanumerical in '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z';
subtype Lower_Alphanumerical is Alphanumerical with Static_Predicate =>
Lower_Alphanumerical in '0' .. '9' | 'a' .. 'z';
subtype Upper_Alphanumerical is Alphanumerical with Static_Predicate =>
Upper_Alphanumerical in '0' .. '9' | 'A' .. 'Z';
Last_Was_Underscore : Boolean := False;
begin
-- Validate the first and last characters: first for invariants shared
-- by all conventions, then for convention-specific invariants.
if Name'Length = 0 then
return False;
end if;
declare
First : Character_Type renames Name (Name'First);
Last : Character_Type renames Name (Name'Last);
begin
case Casing is
when Camel_With_Underscores | Camel =>
if First not in Upper_Alphanumerical
or else Last not in Alphanumerical
then
return False;
end if;
when Lower =>
if First not in Lower_Alphanumerical
or else Last not in Lower_Alphanumerical
then
return False;
end if;
when Upper =>
if First not in Upper_Alphanumerical
or else Last not in Upper_Alphanumerical
then
return False;
end if;
end case;
end;
-- Validate all other characters
for C of Name (Name'First + 1 .. Name'Last - 1) loop
case C is
when '_' =>
-- Underscores are forbidden in Camel, and consecutive
-- underscores are forbidden in all conventions.
if Casing = Camel or else Last_Was_Underscore then
return False;
end if;
Last_Was_Underscore := True;
when Alphanumerical =>
-- Depending on the convention, characters following
-- underscores either must be lower-case or upper-case.
if Last_Was_Underscore then
case Casing is
when Camel_With_Underscores | Upper =>
if C not in Upper_Alphanumerical then
return False;
end if;
when Lower =>
if C not in Lower_Alphanumerical then
return False;
end if;
when Camel =>
raise Program_Error;
end case;
else
case Casing is
when Lower =>
if C not in Lower_Alphanumerical then
return False;
end if;
when Upper =>
if C not in Upper_Alphanumerical then
return False;
end if;
when others =>
null;
end case;
end if;
Last_Was_Underscore := False;
when others =>
return False;
end case;
end loop;
return True;
end Is_Valid_Name;
-----------------
-- Create_Name --
-----------------
function Create_Name
(Name : Text_Type;
Casing : Casing_Convention := Camel_With_Underscores) return Name_Type
is
begin
if not Is_Valid_Name (Name, Casing) then
raise Invalid_Name_Error;
end if;
-- Past this point, we know than Name contains alphanumericals and
-- underscores only, so Image (Name) is just a conversion to ASCII (no
-- escape sequence).
declare
N : String := Image (Name);
begin
-- Unless the casing is already Camel_With_Underscores, convert N to
-- it.
case Casing is
when Camel_With_Underscores =>
return To_Unbounded_String (N);
when Camel =>
return Result : Name_Type do
-- Treat each upper-case letter as the start of a new word
for C of N loop
case C is
when 'A' .. 'Z' =>
if Length (Result) > 0 then
Append (Result, '_');
end if;
Append (Result, C);
when '_' =>
null;
when others =>
Append (Result, C);
end case;
end loop;
end return;
when Lower | Upper =>
declare
Start_Word : Boolean := True;
begin
-- Normalize casing: each start of a word (alphanumericals
-- after underscores) must be upper-case, and the rest in lower
-- case.
for C of N loop
if Start_Word then
C := To_Upper (C);
Start_Word := False;
elsif C = '_' then
Start_Word := True;
else
C := To_Lower (C);
end if;
end loop;
end;
return To_Unbounded_String (N);
end case;
end;
end Create_Name;
-----------------
-- Format_Name --
-----------------
function Format_Name
(Name : Name_Type; Casing : Casing_Convention) return Text_Type
is
N : String := To_String (Name);
Last : Natural := N'Last;
begin
if N'Length = 0 then
raise Invalid_Name_Error;
end if;
case Casing is
when Camel_With_Underscores =>
null;
when Camel =>
-- Strip underscores and preserve all other characters
Last := 0;
for C of N loop
if C /= '_' then
Last := Last + 1;
N (Last) := C;
end if;
end loop;
when Lower =>
for C of N loop
C := To_Lower (C);
end loop;
when Upper =>
for C of N loop
C := To_Upper (C);
end loop;
end case;
return To_Text (N (N'First .. Last));
end Format_Name;
end Gpr_Parser_Support.Names;
|