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 | --
-- Copyright (C) 2021-2023, AdaCore
--
-- SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception
--
with Ada.Strings.Hash;
package body GPR2.View_Ids is
use type GPR2.Context.Context_Kind;
ROOT_VIEWS_PREFIX : constant Character := '<';
AGGR_VIEWS_PREFIX : constant Character := '$';
SPECIAL_VIEWS_PREFIX : constant Character := '!';
EXTENDED_PREFIX : constant Character := '>';
UNDEFINED_IMAGE : constant Value_Type := "";
RUNTIME_IMAGE : constant Value_Type := "runtime";
CONFIG_IMAGE : constant Value_Type := "config";
-------
-- < --
-------
function "<" (Self : View_Id; Other : View_Id) return Boolean is
begin
return Image (Self) < Image (Other);
end "<";
-------
-- = --
-------
overriding function "=" (Self : View_Id; Other : View_Id) return Boolean is
begin
if Self.Kind /= Other.Kind then
return False;
elsif Self.Kind = Project_Id then
return Self.Id = Other.Id
and then Self.Context = Other.Context
and then Self.Extending = Other.Extending;
else
return True;
end if;
end "=";
------------
-- Create --
------------
function Create
(Project_File : GPR2.Path_Name.Object;
Context : GPR2.Context.Context_Kind := Root;
Extending : View_Id := Undefined)
return View_Id
is
Id_Str : Unbounded_String;
begin
if not Project_File.Is_Defined then
raise View_Id_Error with "cannot create view id from empty path";
end if;
if not Project_File.Has_Dir_Name then
raise View_Id_Error with "cannot create view id from relative path";
end if;
Append (Id_Str, GPR2.Path_Name.To_OS_Case (Project_File.Value));
return (Kind => Project_Id,
Id => Id_Str,
Context => Context,
Extending => (if Is_Defined (Extending)
then To_Unbounded_String (String
(Image (Extending)))
else Null_Unbounded_String));
end Create;
----------
-- Hash --
----------
function Hash (Self : View_Id) return Ada.Containers.Hash_Type is
begin
return Ada.Strings.Hash (String (Image (Self)));
end Hash;
-----------
-- Image --
-----------
function Image (Self : View_Id) return Value_Type is
begin
case Self.Kind is
when Null_Id => return UNDEFINED_IMAGE;
when Config_Id => return SPECIAL_VIEWS_PREFIX & CONFIG_IMAGE;
when Runtime_Id => return SPECIAL_VIEWS_PREFIX & RUNTIME_IMAGE;
when Project_Id =>
declare
Extending_Suffix : constant Value_Type :=
(if Length (Self.Extending) = 0
then ""
else EXTENDED_PREFIX &
Value_Type (To_String (Self.Extending)));
begin
if Self.Context = Root then
return ROOT_VIEWS_PREFIX &
Value_Type (To_String (Self.Id)) &
Extending_Suffix;
else
return AGGR_VIEWS_PREFIX &
Value_Type (To_String (Self.Id)) &
Extending_Suffix;
end if;
end;
end case;
end Image;
------------
-- Import --
------------
function Import (Name : Value_Type) return View_Id
is
Prefix : Character;
Id : Value_Type renames
Name (Name'First + 1 .. Name'Last);
Ext_Delimiter : Natural;
Context : GPR2.Context.Context_Kind;
begin
if Name = UNDEFINED_IMAGE then
return (Kind => Null_Id);
end if;
Prefix := Name (Name'First);
if Prefix = SPECIAL_VIEWS_PREFIX then
if Id = CONFIG_IMAGE then
return (Kind => Config_Id);
elsif Id = RUNTIME_IMAGE then
return (Kind => Runtime_Id);
else
raise View_Id_Error with "Invalid view id image";
end if;
end if;
if Prefix = ROOT_VIEWS_PREFIX then
Context := Root;
elsif Prefix = AGGR_VIEWS_PREFIX then
Context := Aggregate;
else
raise View_Id_Error with "invalid view id image";
end if;
Ext_Delimiter := 0;
for J in Id'Range loop
if Id (J) = EXTENDED_PREFIX then
Ext_Delimiter := J;
exit;
end if;
end loop;
if Ext_Delimiter = 0 then
return (Kind => Project_Id,
Id => To_Unbounded_String (String (Id)),
Context => Context,
Extending => Null_Unbounded_String);
else
return (Kind => Project_Id,
Id => To_Unbounded_String (String
(Id (Id'First .. Ext_Delimiter - 1))),
Context => Context,
Extending => To_Unbounded_String (String
(Id (Ext_Delimiter + 1 .. Id'Last))));
end if;
end Import;
--------------------
-- Is_Valid_Image --
--------------------
function Is_Valid_Image (Name : Value_Type) return Boolean is
begin
if Name'Length = 0 then
return True;
elsif Name (Name'First) = SPECIAL_VIEWS_PREFIX then
return Name = SPECIAL_VIEWS_PREFIX & CONFIG_IMAGE
or else Name = SPECIAL_VIEWS_PREFIX & RUNTIME_IMAGE;
else
return Name (Name'First) = ROOT_VIEWS_PREFIX
or else Name (Name'First) = AGGR_VIEWS_PREFIX;
end if;
end Is_Valid_Image;
end GPR2.View_Ids;
|