1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, 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.
67 -- Characteristics of an attribute. Optional_Index indicates that there
68 -- may be an optional index in the index of the associative array, as in
69 -- for Switches ("files.ada" at 2) use ...
71 subtype Defined_Attribute_Kind
is Attribute_Kind
72 range Single
.. Optional_Index_Case_Insensitive_Associative_Array
;
73 -- Subset of Attribute_Kinds that may be used for the attributes that is
74 -- used when defining a new package.
76 Max_Attribute_Name_Length
: constant := 64;
77 -- The maximum length of attribute names
79 subtype Attribute_Name_Length
is
80 Positive range 1 .. Max_Attribute_Name_Length
;
82 type Attribute_Data
(Name_Length
: Attribute_Name_Length
:= 1) is record
83 Name
: String (1 .. Name_Length
);
84 -- The name of the attribute
86 Attr_Kind
: Defined_Attribute_Kind
;
87 -- The type of the attribute
89 Index_Is_File_Name
: Boolean;
90 -- For associative arrays, indicate if the index is a file name, so
91 -- that the attribute kind may be modified depending on the case
92 -- sensitivity of file names. This is only taken into account when
93 -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array.
96 -- True if there may be an optional index in the value of the index,
99 -- ("main.adb", "file.ada" at 1)
101 Var_Kind
: Defined_Variable_Kind
;
102 -- The attribute value kind: single or list
105 -- Name and characteristics of an attribute in a package registered
106 -- explicitly with Register_New_Package (see below).
108 type Attribute_Data_Array
is array (Positive range <>) of Attribute_Data
;
109 -- A list of attribute name/characteristics to be used as parameter of
110 -- procedure Register_New_Package below.
112 -- In the subprograms below, when it is specified that the subprogram
113 -- "fails", procedure Prj.Com.Fail is called. Unless it is specified
114 -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
116 procedure Register_New_Package
118 Attributes
: Attribute_Data_Array
);
119 -- Add a new package with its attributes. This procedure can only be
120 -- called after Initialize, but before any other call to a service of
121 -- the Project Manager. Fail if the name of the package is empty or not
122 -- unique, or if the names of the attributes are not different.
128 type Attribute_Node_Id
is private;
129 -- The type to refers to an attribute, self-initialized
131 Empty_Attribute
: constant Attribute_Node_Id
;
132 -- Indicates no attribute. Default value of Attribute_Node_Id objects
134 Attribute_First
: constant Attribute_Node_Id
;
135 -- First attribute node id of project level attributes
137 function Attribute_Node_Id_Of
139 Starting_At
: Attribute_Node_Id
) return Attribute_Node_Id
;
140 -- Returns the node id of an attribute at the project level or in
141 -- a package. Starting_At indicates the first known attribute node where
142 -- to start the search. Returns Empty_Attribute if the attribute cannot
145 function Attribute_Kind_Of
146 (Attribute
: Attribute_Node_Id
) return Attribute_Kind
;
147 -- Returns the attribute kind of a known attribute. Returns Unknown if
148 -- Attribute is Empty_Attribute.
150 procedure Set_Attribute_Kind_Of
151 (Attribute
: Attribute_Node_Id
;
152 To
: Attribute_Kind
);
153 -- Set the attribute kind of a known attribute. Does nothing if
154 -- Attribute is Empty_Attribute.
156 function Attribute_Name_Of
(Attribute
: Attribute_Node_Id
) return Name_Id
;
157 -- Returns the name of a known attribute. Returns No_Name if Attribute is
160 function Variable_Kind_Of
161 (Attribute
: Attribute_Node_Id
) return Variable_Kind
;
162 -- Returns the variable kind of a known attribute. Returns Undefined if
163 -- Attribute is Empty_Attribute.
165 procedure Set_Variable_Kind_Of
166 (Attribute
: Attribute_Node_Id
;
168 -- Set the variable kind of a known attribute. Does nothing if Attribute is
171 function Optional_Index_Of
(Attribute
: Attribute_Node_Id
) return Boolean;
172 -- Returns True if Attribute is a known attribute and may have an
173 -- optional index. Returns False otherwise.
175 function Is_Read_Only
(Attribute
: Attribute_Node_Id
) return Boolean;
177 function Next_Attribute
178 (After
: Attribute_Node_Id
) return Attribute_Node_Id
;
179 -- Returns the attribute that follow After in the list of project level
180 -- attributes or the list of attributes in a package.
181 -- Returns Empty_Attribute if After is either Empty_Attribute or is the
184 function Others_Allowed_For
(Attribute
: Attribute_Node_Id
) return Boolean;
185 -- True iff the index for an associative array attributes may be others
191 type Package_Node_Id
is private;
192 -- Type to refer to a package, self initialized
194 Empty_Package
: constant Package_Node_Id
;
195 -- Default value of Package_Node_Id objects
197 Unknown_Package
: constant Package_Node_Id
;
198 -- Value of an unknown package that has been found but is unknown
200 procedure Register_New_Package
(Name
: String; Id
: out Package_Node_Id
);
201 -- Add a new package. Fails if Name (the package name) is empty or is
202 -- already the name of a package, and set Id to Empty_Package,
203 -- if Prj.Com.Fail returns. Initially, the new package has no attributes.
204 -- Id may be used to add attributes using procedure Register_New_Attribute
207 procedure Register_New_Attribute
209 In_Package
: Package_Node_Id
;
210 Attr_Kind
: Defined_Attribute_Kind
;
211 Var_Kind
: Defined_Variable_Kind
;
212 Index_Is_File_Name
: Boolean := False;
213 Opt_Index
: Boolean := False);
214 -- Add a new attribute to registered package In_Package. Fails if Name
215 -- (the attribute name) is empty, if In_Package is Empty_Package or if
216 -- the attribute name has a duplicate name. See definition of type
217 -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
218 -- Index_Is_File_Name and Opt_Index.
220 function Package_Node_Id_Of
(Name
: Name_Id
) return Package_Node_Id
;
221 -- Returns the package node id of the package with name Name. Returns
222 -- Empty_Package if there is no package with this name.
224 function First_Attribute_Of
225 (Pkg
: Package_Node_Id
) return Attribute_Node_Id
;
226 -- Returns the first attribute in the list of attributes of package Pkg.
227 -- Returns Empty_Attribute if Pkg is Empty_Package.
234 Attributes_Initial
: constant := 50;
235 Attributes_Increment
: constant := 100;
237 Attribute_Node_Low_Bound
: constant := 0;
238 Attribute_Node_High_Bound
: constant := 099_999_999
;
241 range Attribute_Node_Low_Bound
.. Attribute_Node_High_Bound
;
242 -- Index type for table Attrs in the body
244 type Attribute_Node_Id
is record
245 Value
: Attr_Node_Id
:= Attribute_Node_Low_Bound
;
247 -- Full declaration of self-initialized private type
249 Empty_Attr
: constant Attr_Node_Id
:= Attribute_Node_Low_Bound
;
251 Empty_Attribute
: constant Attribute_Node_Id
:= (Value
=> Empty_Attr
);
253 First_Attribute
: constant Attr_Node_Id
:= Attribute_Node_Low_Bound
+ 1;
255 First_Attribute_Node_Id
: constant Attribute_Node_Id
:=
256 (Value
=> First_Attribute
);
258 Attribute_First
: constant Attribute_Node_Id
:= First_Attribute_Node_Id
;
264 Packages_Initial
: constant := 10;
265 Packages_Increment
: constant := 100;
267 Package_Node_Low_Bound
: constant := 0;
268 Package_Node_High_Bound
: constant := 099_999_999
;
271 range Package_Node_Low_Bound
.. Package_Node_High_Bound
;
272 -- Index type for table Package_Attributes in the body
274 type Package_Node_Id
is record
275 Value
: Pkg_Node_Id
:= Package_Node_Low_Bound
;
277 -- Full declaration of self-initialized private type
279 Empty_Pkg
: constant Pkg_Node_Id
:= Package_Node_Low_Bound
;
280 Empty_Package
: constant Package_Node_Id
:= (Value
=> Empty_Pkg
);
281 Unknown_Pkg
: constant Pkg_Node_Id
:= Package_Node_High_Bound
;
282 Unknown_Package
: constant Package_Node_Id
:= (Value
=> Unknown_Pkg
);
283 First_Package
: constant Pkg_Node_Id
:= Package_Node_Low_Bound
+ 1;
285 First_Package_Node_Id
: constant Package_Node_Id
:=
286 (Value
=> First_Package
);
288 Package_First
: constant Package_Node_Id
:= First_Package_Node_Id
;
294 type Attribute_Record
is record
296 Var_Kind
: Variable_Kind
;
297 Optional_Index
: Boolean;
298 Attr_Kind
: Attribute_Kind
;
300 Others_Allowed
: Boolean;
303 -- Data for an attribute
306 new Table
.Table
(Table_Component_Type
=> Attribute_Record
,
307 Table_Index_Type
=> Attr_Node_Id
,
308 Table_Low_Bound
=> First_Attribute
,
309 Table_Initial
=> Attributes_Initial
,
310 Table_Increment
=> Attributes_Increment
,
311 Table_Name
=> "Prj.Attr.Attrs");
312 -- The table of the attributes
318 type Package_Record
is record
320 Known
: Boolean := True;
321 First_Attribute
: Attr_Node_Id
;
323 -- Data for a package
325 package Package_Attributes
is
326 new Table
.Table
(Table_Component_Type
=> Package_Record
,
327 Table_Index_Type
=> Pkg_Node_Id
,
328 Table_Low_Bound
=> First_Package
,
329 Table_Initial
=> Packages_Initial
,
330 Table_Increment
=> Packages_Increment
,
331 Table_Name
=> "Prj.Attr.Packages");
332 -- The table of the packages