1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2013, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package defines packages and attributes in GNAT project files.
27 -- There are predefined packages and attributes.
29 -- It is also possible to define new packages with their attributes
37 function Package_Name_List
return GNAT
.Strings
.String_List
;
38 -- Returns the list of valid package names, including those added by
39 -- procedures Register_New_Package below. The String_Access components of
40 -- the returned String_List should never be freed.
43 -- Initialize the predefined project level attributes and the predefined
44 -- packages and their attribute. This procedure should be called by
47 type Attribute_Kind
is (
49 -- The attribute does not exist
52 -- Single variable attribute (not an associative array)
55 -- Associative array attribute with a case sensitive index
57 Optional_Index_Associative_Array
,
58 -- Associative array attribute with a case sensitive index and an
59 -- optional source index.
61 Case_Insensitive_Associative_Array
,
62 -- Associative array attribute with a case insensitive index
64 Optional_Index_Case_Insensitive_Associative_Array
65 -- Associative array attribute with a case insensitive index and an
66 -- optional source index.
68 -- Characteristics of an attribute. Optional_Index indicates that there
69 -- may be an optional index in the index of the associative array, as in
70 -- for Switches ("files.ada" at 2) use ...
72 subtype Defined_Attribute_Kind
is Attribute_Kind
73 range Single
.. Optional_Index_Case_Insensitive_Associative_Array
;
74 -- Subset of Attribute_Kinds that may be used for the attributes that is
75 -- used when defining a new package.
77 subtype All_Case_Insensitive_Associative_Array
is Attribute_Kind
range
78 Case_Insensitive_Associative_Array
..
79 Optional_Index_Case_Insensitive_Associative_Array
;
80 -- Subtype including both cases of Case_Insensitive_Associative_Array
82 Max_Attribute_Name_Length
: constant := 64;
83 -- The maximum length of attribute names
85 subtype Attribute_Name_Length
is
86 Positive range 1 .. Max_Attribute_Name_Length
;
88 type Attribute_Data
(Name_Length
: Attribute_Name_Length
:= 1) is record
89 Name
: String (1 .. Name_Length
);
90 -- The name of the attribute
92 Attr_Kind
: Defined_Attribute_Kind
;
93 -- The type of the attribute
95 Index_Is_File_Name
: Boolean;
96 -- For associative arrays, indicate if the index is a file name, so
97 -- that the attribute kind may be modified depending on the case
98 -- sensitivity of file names. This is only taken into account when
99 -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array.
102 -- True if there may be an optional index in the value of the index,
105 -- ("main.adb", "file.ada" at 1)
107 Var_Kind
: Defined_Variable_Kind
;
108 -- The attribute value kind: single or list
111 -- Name and characteristics of an attribute in a package registered
112 -- explicitly with Register_New_Package (see below).
114 type Attribute_Data_Array
is array (Positive range <>) of Attribute_Data
;
115 -- A list of attribute name/characteristics to be used as parameter of
116 -- procedure Register_New_Package below.
118 -- In the subprograms below, when it is specified that the subprogram
119 -- "fails", procedure Prj.Com.Fail is called. Unless it is specified
120 -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
122 procedure Register_New_Package
124 Attributes
: Attribute_Data_Array
);
125 -- Add a new package with its attributes. This procedure can only be
126 -- called after Initialize, but before any other call to a service of
127 -- the Project Manager. Fail if the name of the package is empty or not
128 -- unique, or if the names of the attributes are not different.
134 type Attribute_Node_Id
is private;
135 -- The type to refers to an attribute, self-initialized
137 Empty_Attribute
: constant Attribute_Node_Id
;
138 -- Indicates no attribute. Default value of Attribute_Node_Id objects
140 Attribute_First
: constant Attribute_Node_Id
;
141 -- First attribute node id of project level attributes
143 function Attribute_Node_Id_Of
145 Starting_At
: Attribute_Node_Id
) return Attribute_Node_Id
;
146 -- Returns the node id of an attribute at the project level or in
147 -- a package. Starting_At indicates the first known attribute node where
148 -- to start the search. Returns Empty_Attribute if the attribute cannot
151 function Attribute_Kind_Of
152 (Attribute
: Attribute_Node_Id
) return Attribute_Kind
;
153 -- Returns the attribute kind of a known attribute. Returns Unknown if
154 -- Attribute is Empty_Attribute.
156 -- To use this function, the following code should be used:
158 -- Pkg : constant Package_Node_Id :=
159 -- Prj.Attr.Package_Node_Id_Of (Name => <package name>);
160 -- Att : constant Attribute_Node_Id :=
161 -- Prj.Attr.Attribute_Node_Id_Of
162 -- (Name => <attribute name>,
163 -- Starting_At => First_Attribute_Of (Pkg));
164 -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att);
166 -- However, do not use this function once you have an already parsed
167 -- project tree. Instead, given a Project_Node_Id corresponding to the
168 -- attribute declaration ("for Attr (index) use ..."), use for example:
170 -- if Case_Insensitive (Attr, Tree) then ...
172 procedure Set_Attribute_Kind_Of
173 (Attribute
: Attribute_Node_Id
;
174 To
: Attribute_Kind
);
175 -- Set the attribute kind of a known attribute. Does nothing if
176 -- Attribute is Empty_Attribute.
178 function Attribute_Name_Of
(Attribute
: Attribute_Node_Id
) return Name_Id
;
179 -- Returns the name of a known attribute. Returns No_Name if Attribute is
182 function Variable_Kind_Of
183 (Attribute
: Attribute_Node_Id
) return Variable_Kind
;
184 -- Returns the variable kind of a known attribute. Returns Undefined if
185 -- Attribute is Empty_Attribute.
187 procedure Set_Variable_Kind_Of
188 (Attribute
: Attribute_Node_Id
;
190 -- Set the variable kind of a known attribute. Does nothing if Attribute is
193 function Optional_Index_Of
(Attribute
: Attribute_Node_Id
) return Boolean;
194 -- Returns True if Attribute is a known attribute and may have an
195 -- optional index. Returns False otherwise.
197 function Is_Read_Only
(Attribute
: Attribute_Node_Id
) return Boolean;
199 function Next_Attribute
200 (After
: Attribute_Node_Id
) return Attribute_Node_Id
;
201 -- Returns the attribute that follow After in the list of project level
202 -- attributes or the list of attributes in a package.
203 -- Returns Empty_Attribute if After is either Empty_Attribute or is the
206 function Others_Allowed_For
(Attribute
: Attribute_Node_Id
) return Boolean;
207 -- True iff the index for an associative array attributes may be others
213 type Package_Node_Id
is private;
214 -- Type to refer to a package, self initialized
216 Empty_Package
: constant Package_Node_Id
;
217 -- Default value of Package_Node_Id objects
219 Unknown_Package
: constant Package_Node_Id
;
220 -- Value of an unknown package that has been found but is unknown
222 procedure Register_New_Package
(Name
: String; Id
: out Package_Node_Id
);
223 -- Add a new package. Fails if Name (the package name) is empty or is
224 -- already the name of a package, and set Id to Empty_Package,
225 -- if Prj.Com.Fail returns. Initially, the new package has no attributes.
226 -- Id may be used to add attributes using procedure Register_New_Attribute
229 procedure Register_New_Attribute
231 In_Package
: Package_Node_Id
;
232 Attr_Kind
: Defined_Attribute_Kind
;
233 Var_Kind
: Defined_Variable_Kind
;
234 Index_Is_File_Name
: Boolean := False;
235 Opt_Index
: Boolean := False);
236 -- Add a new attribute to registered package In_Package. Fails if Name
237 -- (the attribute name) is empty, if In_Package is Empty_Package or if
238 -- the attribute name has a duplicate name. See definition of type
239 -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
240 -- Index_Is_File_Name and Opt_Index.
242 function Package_Node_Id_Of
(Name
: Name_Id
) return Package_Node_Id
;
243 -- Returns the package node id of the package with name Name. Returns
244 -- Empty_Package if there is no package with this name.
246 function First_Attribute_Of
247 (Pkg
: Package_Node_Id
) return Attribute_Node_Id
;
248 -- Returns the first attribute in the list of attributes of package Pkg.
249 -- Returns Empty_Attribute if Pkg is Empty_Package or Unknown_Package.
256 Attributes_Initial
: constant := 50;
257 Attributes_Increment
: constant := 100;
259 Attribute_Node_Low_Bound
: constant := 0;
260 Attribute_Node_High_Bound
: constant := 099_999_999
;
263 range Attribute_Node_Low_Bound
.. Attribute_Node_High_Bound
;
264 -- Index type for table Attrs in the body
266 type Attribute_Node_Id
is record
267 Value
: Attr_Node_Id
:= Attribute_Node_Low_Bound
;
269 -- Full declaration of self-initialized private type
271 Empty_Attr
: constant Attr_Node_Id
:= Attribute_Node_Low_Bound
;
273 Empty_Attribute
: constant Attribute_Node_Id
:= (Value
=> Empty_Attr
);
275 First_Attribute
: constant Attr_Node_Id
:= Attribute_Node_Low_Bound
+ 1;
277 First_Attribute_Node_Id
: constant Attribute_Node_Id
:=
278 (Value
=> First_Attribute
);
280 Attribute_First
: constant Attribute_Node_Id
:= First_Attribute_Node_Id
;
286 Packages_Initial
: constant := 10;
287 Packages_Increment
: constant := 100;
289 Package_Node_Low_Bound
: constant := 0;
290 Package_Node_High_Bound
: constant := 099_999_999
;
293 range Package_Node_Low_Bound
.. Package_Node_High_Bound
;
294 -- Index type for table Package_Attributes in the body
296 type Package_Node_Id
is record
297 Value
: Pkg_Node_Id
:= Package_Node_Low_Bound
;
299 -- Full declaration of self-initialized private type
301 Empty_Pkg
: constant Pkg_Node_Id
:= Package_Node_Low_Bound
;
302 Empty_Package
: constant Package_Node_Id
:= (Value
=> Empty_Pkg
);
303 Unknown_Pkg
: constant Pkg_Node_Id
:= Package_Node_High_Bound
;
304 Unknown_Package
: constant Package_Node_Id
:= (Value
=> Unknown_Pkg
);
305 First_Package
: constant Pkg_Node_Id
:= Package_Node_Low_Bound
+ 1;
307 First_Package_Node_Id
: constant Package_Node_Id
:=
308 (Value
=> First_Package
);
310 Package_First
: constant Package_Node_Id
:= First_Package_Node_Id
;
316 type Attribute_Record
is record
318 Var_Kind
: Variable_Kind
;
319 Optional_Index
: Boolean;
320 Attr_Kind
: Attribute_Kind
;
322 Others_Allowed
: Boolean;
325 -- Data for an attribute
328 new Table
.Table
(Table_Component_Type
=> Attribute_Record
,
329 Table_Index_Type
=> Attr_Node_Id
,
330 Table_Low_Bound
=> First_Attribute
,
331 Table_Initial
=> Attributes_Initial
,
332 Table_Increment
=> Attributes_Increment
,
333 Table_Name
=> "Prj.Attr.Attrs");
334 -- The table of the attributes
340 type Package_Record
is record
342 Known
: Boolean := True;
343 First_Attribute
: Attr_Node_Id
;
345 -- Data for a package
347 package Package_Attributes
is
348 new Table
.Table
(Table_Component_Type
=> Package_Record
,
349 Table_Index_Type
=> Pkg_Node_Id
,
350 Table_Low_Bound
=> First_Package
,
351 Table_Initial
=> Packages_Initial
,
352 Table_Increment
=> Packages_Increment
,
353 Table_Name
=> "Prj.Attr.Packages");
354 -- The table of the packages