1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . A T T R -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- 10-- -- 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. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- This package defines packages and attributes in GNAT project files. 27-- There are predefined packages and attributes. 28 29-- It is also possible to define new packages with their attributes 30 31with Table; 32 33with GNAT.Strings; 34 35package Prj.Attr is 36 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. 41 42 procedure Initialize; 43 -- Initialize the predefined project level attributes and the predefined 44 -- packages and their attribute. This procedure should be called by 45 -- Prj.Initialize. 46 47 type Attribute_Kind is ( 48 Unknown, 49 -- The attribute does not exist 50 51 Single, 52 -- Single variable attribute (not an associative array) 53 54 Associative_Array, 55 -- Associative array attribute with a case sensitive index 56 57 Optional_Index_Associative_Array, 58 -- Associative array attribute with a case sensitive index and an 59 -- optional source index. 60 61 Case_Insensitive_Associative_Array, 62 -- Associative array attribute with a case insensitive index 63 64 Optional_Index_Case_Insensitive_Associative_Array 65 -- Associative array attribute with a case insensitive index and an 66 -- optional source index. 67 ); 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 ... 71 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. 76 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 81 82 Max_Attribute_Name_Length : constant := 64; 83 -- The maximum length of attribute names 84 85 subtype Attribute_Name_Length is 86 Positive range 1 .. Max_Attribute_Name_Length; 87 88 type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record 89 Name : String (1 .. Name_Length); 90 -- The name of the attribute 91 92 Attr_Kind : Defined_Attribute_Kind; 93 -- The type of the attribute 94 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. 100 101 Opt_Index : Boolean; 102 -- True if there may be an optional index in the value of the index, 103 -- as in: 104 -- "file.ada" at 2 105 -- ("main.adb", "file.ada" at 1) 106 107 Var_Kind : Defined_Variable_Kind; 108 -- The attribute value kind: single or list 109 110 Default : Attribute_Default_Value := Empty_Value; 111 -- The value of the attribute when referenced if the attribute has not 112 -- yet been declared. 113 114 end record; 115 -- Name and characteristics of an attribute in a package registered 116 -- explicitly with Register_New_Package (see below). 117 118 type Attribute_Data_Array is array (Positive range <>) of Attribute_Data; 119 -- A list of attribute name/characteristics to be used as parameter of 120 -- procedure Register_New_Package below. 121 122 -- In the subprograms below, when it is specified that the subprogram 123 -- "fails", procedure Prj.Com.Fail is called. Unless it is specified 124 -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised. 125 126 procedure Register_New_Package 127 (Name : String; 128 Attributes : Attribute_Data_Array); 129 -- Add a new package with its attributes. This procedure can only be 130 -- called after Initialize, but before any other call to a service of 131 -- the Project Manager. Fail if the name of the package is empty or not 132 -- unique, or if the names of the attributes are not different. 133 134 ---------------- 135 -- Attributes -- 136 ---------------- 137 138 type Attribute_Node_Id is private; 139 -- The type to refers to an attribute, self-initialized 140 141 Empty_Attribute : constant Attribute_Node_Id; 142 -- Indicates no attribute. Default value of Attribute_Node_Id objects 143 144 Attribute_First : constant Attribute_Node_Id; 145 -- First attribute node id of project level attributes 146 147 function Attribute_Node_Id_Of 148 (Name : Name_Id; 149 Starting_At : Attribute_Node_Id) return Attribute_Node_Id; 150 -- Returns the node id of an attribute at the project level or in 151 -- a package. Starting_At indicates the first known attribute node where 152 -- to start the search. Returns Empty_Attribute if the attribute cannot 153 -- be found. 154 155 function Attribute_Kind_Of 156 (Attribute : Attribute_Node_Id) return Attribute_Kind; 157 -- Returns the attribute kind of a known attribute. Returns Unknown if 158 -- Attribute is Empty_Attribute. 159 -- 160 -- To use this function, the following code should be used: 161 -- 162 -- Pkg : constant Package_Node_Id := 163 -- Prj.Attr.Package_Node_Id_Of (Name => <package name>); 164 -- Att : constant Attribute_Node_Id := 165 -- Prj.Attr.Attribute_Node_Id_Of 166 -- (Name => <attribute name>, 167 -- Starting_At => First_Attribute_Of (Pkg)); 168 -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att); 169 -- 170 -- However, do not use this function once you have an already parsed 171 -- project tree. Instead, given a Project_Node_Id corresponding to the 172 -- attribute declaration ("for Attr (index) use ..."), use for example: 173 -- 174 -- if Case_Insensitive (Attr, Tree) then ... 175 176 procedure Set_Attribute_Kind_Of 177 (Attribute : Attribute_Node_Id; 178 To : Attribute_Kind); 179 -- Set the attribute kind of a known attribute. Does nothing if 180 -- Attribute is Empty_Attribute. 181 182 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id; 183 -- Returns the name of a known attribute. Returns No_Name if Attribute is 184 -- Empty_Attribute. 185 186 function Variable_Kind_Of 187 (Attribute : Attribute_Node_Id) return Variable_Kind; 188 -- Returns the variable kind of a known attribute. Returns Undefined if 189 -- Attribute is Empty_Attribute. 190 191 procedure Set_Variable_Kind_Of 192 (Attribute : Attribute_Node_Id; 193 To : Variable_Kind); 194 -- Set the variable kind of a known attribute. Does nothing if Attribute is 195 -- Empty_Attribute. 196 197 function Attribute_Default_Of 198 (Attribute : Attribute_Node_Id) return Attribute_Default_Value; 199 -- Returns the default of the attribute, Read_Only_Value for read only 200 -- attributes, Empty_Value when default not specified, or specified value. 201 202 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean; 203 -- Returns True if Attribute is a known attribute and may have an 204 -- optional index. Returns False otherwise. 205 206 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean; 207 208 function Next_Attribute 209 (After : Attribute_Node_Id) return Attribute_Node_Id; 210 -- Returns the attribute that follow After in the list of project level 211 -- attributes or the list of attributes in a package. 212 -- Returns Empty_Attribute if After is either Empty_Attribute or is the 213 -- last of the list. 214 215 function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean; 216 -- True iff the index for an associative array attributes may be others 217 218 -------------- 219 -- Packages -- 220 -------------- 221 222 type Package_Node_Id is private; 223 -- Type to refer to a package, self initialized 224 225 Empty_Package : constant Package_Node_Id; 226 -- Default value of Package_Node_Id objects 227 228 Unknown_Package : constant Package_Node_Id; 229 -- Value of an unknown package that has been found but is unknown 230 231 procedure Register_New_Package (Name : String; Id : out Package_Node_Id); 232 -- Add a new package. Fails if Name (the package name) is empty or is 233 -- already the name of a package, and set Id to Empty_Package, 234 -- if Prj.Com.Fail returns. Initially, the new package has no attributes. 235 -- Id may be used to add attributes using procedure Register_New_Attribute 236 -- below. 237 238 procedure Register_New_Attribute 239 (Name : String; 240 In_Package : Package_Node_Id; 241 Attr_Kind : Defined_Attribute_Kind; 242 Var_Kind : Defined_Variable_Kind; 243 Index_Is_File_Name : Boolean := False; 244 Opt_Index : Boolean := False; 245 Default : Attribute_Default_Value := Empty_Value); 246 -- Add a new attribute to registered package In_Package. Fails if Name 247 -- (the attribute name) is empty, if In_Package is Empty_Package or if 248 -- the attribute name has a duplicate name. See definition of type 249 -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind, 250 -- Index_Is_File_Name, Opt_Index, and Default. 251 252 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; 253 -- Returns the package node id of the package with name Name. Returns 254 -- Empty_Package if there is no package with this name. 255 256 function First_Attribute_Of 257 (Pkg : Package_Node_Id) return Attribute_Node_Id; 258 -- Returns the first attribute in the list of attributes of package Pkg. 259 -- Returns Empty_Attribute if Pkg is Empty_Package or Unknown_Package. 260 261private 262 ---------------- 263 -- Attributes -- 264 ---------------- 265 266 Attributes_Initial : constant := 50; 267 Attributes_Increment : constant := 100; 268 269 Attribute_Node_Low_Bound : constant := 0; 270 Attribute_Node_High_Bound : constant := 099_999_999; 271 272 type Attr_Node_Id is 273 range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound; 274 -- Index type for table Attrs in the body 275 276 type Attribute_Node_Id is record 277 Value : Attr_Node_Id := Attribute_Node_Low_Bound; 278 end record; 279 -- Full declaration of self-initialized private type 280 281 Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound; 282 283 Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr); 284 285 First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1; 286 287 First_Attribute_Node_Id : constant Attribute_Node_Id := 288 (Value => First_Attribute); 289 290 Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id; 291 292 -------------- 293 -- Packages -- 294 -------------- 295 296 Packages_Initial : constant := 10; 297 Packages_Increment : constant := 100; 298 299 Package_Node_Low_Bound : constant := 0; 300 Package_Node_High_Bound : constant := 099_999_999; 301 302 type Pkg_Node_Id is 303 range Package_Node_Low_Bound .. Package_Node_High_Bound; 304 -- Index type for table Package_Attributes in the body 305 306 type Package_Node_Id is record 307 Value : Pkg_Node_Id := Package_Node_Low_Bound; 308 end record; 309 -- Full declaration of self-initialized private type 310 311 Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound; 312 Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg); 313 Unknown_Pkg : constant Pkg_Node_Id := Package_Node_High_Bound; 314 Unknown_Package : constant Package_Node_Id := (Value => Unknown_Pkg); 315 First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1; 316 317 First_Package_Node_Id : constant Package_Node_Id := 318 (Value => First_Package); 319 320 Package_First : constant Package_Node_Id := First_Package_Node_Id; 321 322 ---------------- 323 -- Attributes -- 324 ---------------- 325 326 type Attribute_Record is record 327 Name : Name_Id; 328 Var_Kind : Variable_Kind; 329 Optional_Index : Boolean; 330 Attr_Kind : Attribute_Kind; 331 Read_Only : Boolean; 332 Others_Allowed : Boolean; 333 Default : Attribute_Default_Value; 334 Next : Attr_Node_Id; 335 end record; 336 -- Data for an attribute 337 338 package Attrs is 339 new Table.Table (Table_Component_Type => Attribute_Record, 340 Table_Index_Type => Attr_Node_Id, 341 Table_Low_Bound => First_Attribute, 342 Table_Initial => Attributes_Initial, 343 Table_Increment => Attributes_Increment, 344 Table_Name => "Prj.Attr.Attrs"); 345 -- The table of the attributes 346 347 -------------- 348 -- Packages -- 349 -------------- 350 351 type Package_Record is record 352 Name : Name_Id; 353 Known : Boolean := True; 354 First_Attribute : Attr_Node_Id; 355 end record; 356 -- Data for a package 357 358 package Package_Attributes is 359 new Table.Table (Table_Component_Type => Package_Record, 360 Table_Index_Type => Pkg_Node_Id, 361 Table_Low_Bound => First_Package, 362 Table_Initial => Packages_Initial, 363 Table_Increment => Packages_Increment, 364 Table_Name => "Prj.Attr.Packages"); 365 -- The table of the packages 366 367end Prj.Attr; 368