]>
Commit | Line | Data |
---|---|---|
49d882a7 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
9dfe12ae | 5 | -- P R J . A T T R -- |
49d882a7 | 6 | -- -- |
7 | -- B o d y -- | |
8 | -- -- | |
47d41b14 | 9 | -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- |
49d882a7 | 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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
49d882a7 | 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 -- | |
80df182a | 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. -- | |
49d882a7 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
49d882a7 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
44d43e97 | 26 | with Osint; |
27 | with Prj.Com; use Prj.Com; | |
f17fd3d9 | 28 | |
29 | with GNAT.Case_Util; use GNAT.Case_Util; | |
49d882a7 | 30 | |
31 | package body Prj.Attr is | |
32 | ||
f17fd3d9 | 33 | use GNAT; |
34 | ||
8f71d067 | 35 | -- Data for predefined attributes and packages |
36 | ||
dbc3c229 | 37 | -- Names are in lower case and end with '#' |
432136f2 | 38 | |
49d882a7 | 39 | -- Package names are preceded by 'P' |
432136f2 | 40 | |
dbc3c229 | 41 | -- Attribute names are preceded by two or three letters: |
44d43e97 | 42 | |
432136f2 | 43 | -- The first letter is one of |
44 | -- 'S' for Single | |
1bbc9831 | 45 | -- 's' for Single with optional index |
46 | -- 'L' for List | |
47 | -- 'l' for List of strings with optional indexes | |
44d43e97 | 48 | |
432136f2 | 49 | -- The second letter is one of |
50 | -- 'V' for single variable | |
51 | -- 'A' for associative array | |
52 | -- 'a' for case insensitive associative array | |
9dfe12ae | 53 | -- 'b' for associative array, case insensitive if file names are case |
54 | -- insensitive | |
1bbc9831 | 55 | -- 'c' same as 'b', with optional index |
432136f2 | 56 | |
dbc3c229 | 57 | -- The third optional letter is |
58 | -- 'R' to indicate that the attribute is read-only | |
9c0520cb | 59 | -- 'O' to indicate that others is allowed as an index for an associative |
60 | -- array | |
dbc3c229 | 61 | |
7ebd25a4 | 62 | -- End is indicated by two consecutive '#' |
49d882a7 | 63 | |
9ffca0cd | 64 | Initialization_Data : constant String := |
49d882a7 | 65 | |
dbc3c229 | 66 | -- project level attributes |
67 | ||
68 | -- General | |
69 | ||
70 | "SVRname#" & | |
75209ec5 | 71 | "SVRproject_dir#" & |
dbc3c229 | 72 | "lVmain#" & |
73 | "LVlanguages#" & | |
e7084ad5 | 74 | "Lbroots#" & |
dbc3c229 | 75 | "SVexternally_built#" & |
76 | ||
77 | -- Directories | |
78 | ||
79 | "SVobject_dir#" & | |
80 | "SVexec_dir#" & | |
81 | "LVsource_dirs#" & | |
f17fd3d9 | 82 | "Lainherit_source_path#" & |
b5766bfb | 83 | "LVexcluded_source_dirs#" & |
f0df06af | 84 | "LVignore_source_sub_dirs#" & |
dbc3c229 | 85 | |
86 | -- Source files | |
87 | ||
88 | "LVsource_files#" & | |
89 | "LVlocally_removed_files#" & | |
b5766bfb | 90 | "LVexcluded_source_files#" & |
dbc3c229 | 91 | "SVsource_list_file#" & |
bcd6aed7 | 92 | "SVexcluded_source_list_file#" & |
ba381ae5 | 93 | "LVinterfaces#" & |
dbc3c229 | 94 | |
cd3c2a98 | 95 | -- Projects (in aggregate projects) |
96 | ||
97 | "LVproject_files#" & | |
98 | "LVproject_path#" & | |
99 | "SAexternal#" & | |
100 | ||
dbc3c229 | 101 | -- Libraries |
102 | ||
103 | "SVlibrary_dir#" & | |
104 | "SVlibrary_name#" & | |
105 | "SVlibrary_kind#" & | |
106 | "SVlibrary_version#" & | |
107 | "LVlibrary_interface#" & | |
1b561726 | 108 | "SVlibrary_standalone#" & |
43d776b7 | 109 | "LVlibrary_encapsulated_options#" & |
110 | "SVlibrary_encapsulated_supported#" & | |
dbc3c229 | 111 | "SVlibrary_auto_init#" & |
eb704cc6 | 112 | "LVleading_library_options#" & |
dbc3c229 | 113 | "LVlibrary_options#" & |
114 | "SVlibrary_src_dir#" & | |
115 | "SVlibrary_ali_dir#" & | |
116 | "SVlibrary_gcc#" & | |
117 | "SVlibrary_symbol_file#" & | |
118 | "SVlibrary_symbol_policy#" & | |
119 | "SVlibrary_reference_symbol_file#" & | |
120 | ||
121 | -- Configuration - General | |
122 | ||
123 | "SVdefault_language#" & | |
124 | "LVrun_path_option#" & | |
2a62ce00 | 125 | "SVrun_path_origin#" & |
2f80f1db | 126 | "SVseparate_run_path_options#" & |
dbc3c229 | 127 | "Satoolchain_version#" & |
128 | "Satoolchain_description#" & | |
ba381ae5 | 129 | "Saobject_generated#" & |
130 | "Saobjects_linked#" & | |
1dffe15c | 131 | "SVtarget#" & |
dbc3c229 | 132 | |
133 | -- Configuration - Libraries | |
134 | ||
135 | "SVlibrary_builder#" & | |
136 | "SVlibrary_support#" & | |
137 | ||
138 | -- Configuration - Archives | |
139 | ||
140 | "LVarchive_builder#" & | |
f17fd3d9 | 141 | "LVarchive_builder_append_option#" & |
dbc3c229 | 142 | "LVarchive_indexer#" & |
143 | "SVarchive_suffix#" & | |
144 | "LVlibrary_partial_linker#" & | |
145 | ||
146 | -- Configuration - Shared libraries | |
147 | ||
148 | "SVshared_library_prefix#" & | |
149 | "SVshared_library_suffix#" & | |
150 | "SVsymbolic_link_supported#" & | |
151 | "SVlibrary_major_minor_id_supported#" & | |
152 | "SVlibrary_auto_init_supported#" & | |
153 | "LVshared_library_minimum_switches#" & | |
154 | "LVlibrary_version_switches#" & | |
2a62ce00 | 155 | "SVlibrary_install_name_option#" & |
cd358009 | 156 | "Saruntime_library_dir#" & |
c7f78e2d | 157 | "Saruntime_source_dir#" & |
49d882a7 | 158 | |
159 | -- package Naming | |
cd3c2a98 | 160 | -- Some attributes are obsolescent, and renamed in the tree (see |
161 | -- Prj.Dect.Rename_Obsolescent_Attributes). | |
49d882a7 | 162 | |
dbc3c229 | 163 | "Pnaming#" & |
cd3c2a98 | 164 | "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree |
dbc3c229 | 165 | "Saspec_suffix#" & |
cd3c2a98 | 166 | "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree |
dbc3c229 | 167 | "Sabody_suffix#" & |
168 | "SVseparate_suffix#" & | |
169 | "SVcasing#" & | |
170 | "SVdot_replacement#" & | |
47d41b14 | 171 | "saspecification#" & -- Always renamed to "spec" in project tree |
172 | "saspec#" & | |
173 | "saimplementation#" & -- Always renamed to "body" in project tree | |
174 | "sabody#" & | |
dbc3c229 | 175 | "Laspecification_exceptions#" & |
176 | "Laimplementation_exceptions#" & | |
49d882a7 | 177 | |
178 | -- package Compiler | |
179 | ||
dbc3c229 | 180 | "Pcompiler#" & |
181 | "Ladefault_switches#" & | |
9c0520cb | 182 | "LcOswitches#" & |
dbc3c229 | 183 | "SVlocal_configuration_pragmas#" & |
184 | "Salocal_config_file#" & | |
185 | ||
186 | -- Configuration - Compiling | |
187 | ||
188 | "Sadriver#" & | |
ab19a652 | 189 | "Salanguage_kind#" & |
190 | "Sadependency_kind#" & | |
f0933359 | 191 | "Larequired_switches#" & |
96557d1c | 192 | "Laleading_required_switches#" & |
193 | "Latrailing_required_switches#" & | |
dbc3c229 | 194 | "Lapic_option#" & |
6dbe70ce | 195 | "Sapath_syntax#" & |
6854063c | 196 | "Lasource_file_switches#" & |
557df72f | 197 | "Saobject_file_suffix#" & |
1cdb8aba | 198 | "Laobject_file_switches#" & |
447b1f65 | 199 | "Lamulti_unit_switches#" & |
200 | "Samulti_unit_object_separator#" & | |
dbc3c229 | 201 | |
202 | -- Configuration - Mapping files | |
203 | ||
204 | "Lamapping_file_switches#" & | |
205 | "Samapping_spec_suffix#" & | |
206 | "Samapping_body_suffix#" & | |
207 | ||
208 | -- Configuration - Config files | |
209 | ||
210 | "Laconfig_file_switches#" & | |
211 | "Saconfig_body_file_name#" & | |
447b1f65 | 212 | "Saconfig_body_file_name_index#" & |
dbc3c229 | 213 | "Saconfig_body_file_name_pattern#" & |
447b1f65 | 214 | "Saconfig_spec_file_name#" & |
215 | "Saconfig_spec_file_name_index#" & | |
dbc3c229 | 216 | "Saconfig_spec_file_name_pattern#" & |
217 | "Saconfig_file_unique#" & | |
218 | ||
219 | -- Configuration - Dependencies | |
220 | ||
221 | "Ladependency_switches#" & | |
e7084ad5 | 222 | "Ladependency_driver#" & |
dbc3c229 | 223 | |
224 | -- Configuration - Search paths | |
225 | ||
226 | "Lainclude_switches#" & | |
227 | "Sainclude_path#" & | |
228 | "Sainclude_path_file#" & | |
49d882a7 | 229 | |
42f613d5 | 230 | -- package Builder |
49d882a7 | 231 | |
dbc3c229 | 232 | "Pbuilder#" & |
233 | "Ladefault_switches#" & | |
9c0520cb | 234 | "LcOswitches#" & |
5210eee9 | 235 | "Lcglobal_compilation_switches#" & |
dbc3c229 | 236 | "Scexecutable#" & |
237 | "SVexecutable_suffix#" & | |
238 | "SVglobal_configuration_pragmas#" & | |
239 | "Saglobal_config_file#" & | |
49d882a7 | 240 | |
241 | -- package gnatls | |
242 | ||
dbc3c229 | 243 | "Pgnatls#" & |
244 | "LVswitches#" & | |
49d882a7 | 245 | |
42f613d5 | 246 | -- package Binder |
49d882a7 | 247 | |
dbc3c229 | 248 | "Pbinder#" & |
249 | "Ladefault_switches#" & | |
9c0520cb | 250 | "LcOswitches#" & |
dbc3c229 | 251 | |
252 | -- Configuration - Binding | |
253 | ||
254 | "Sadriver#" & | |
f0933359 | 255 | "Larequired_switches#" & |
dbc3c229 | 256 | "Saprefix#" & |
257 | "Saobjects_path#" & | |
258 | "Saobjects_path_file#" & | |
49d882a7 | 259 | |
42f613d5 | 260 | -- package Linker |
49d882a7 | 261 | |
dbc3c229 | 262 | "Plinker#" & |
263 | "LVrequired_switches#" & | |
264 | "Ladefault_switches#" & | |
eb704cc6 | 265 | "LcOleading_switches#" & |
9c0520cb | 266 | "LcOswitches#" & |
dbc3c229 | 267 | "LVlinker_options#" & |
98d6f5eb | 268 | "SVmap_file_option#" & |
dbc3c229 | 269 | |
270 | -- Configuration - Linking | |
271 | ||
272 | "SVdriver#" & | |
273 | "LVexecutable_switch#" & | |
274 | "SVlib_dir_switch#" & | |
275 | "SVlib_name_switch#" & | |
42f613d5 | 276 | |
19b4517d | 277 | -- Configuration - Response files |
278 | ||
279 | "SVmax_command_line_length#" & | |
280 | "SVresponse_file_format#" & | |
281 | "LVresponse_file_switches#" & | |
282 | ||
42f613d5 | 283 | -- package Cross_Reference |
284 | ||
dbc3c229 | 285 | "Pcross_reference#" & |
286 | "Ladefault_switches#" & | |
9c0520cb | 287 | "LbOswitches#" & |
42f613d5 | 288 | |
289 | -- package Finder | |
290 | ||
dbc3c229 | 291 | "Pfinder#" & |
292 | "Ladefault_switches#" & | |
9c0520cb | 293 | "LbOswitches#" & |
49d882a7 | 294 | |
9dfe12ae | 295 | -- package Pretty_Printer |
296 | ||
dbc3c229 | 297 | "Ppretty_printer#" & |
298 | "Ladefault_switches#" & | |
9c0520cb | 299 | "LbOswitches#" & |
9dfe12ae | 300 | |
301 | -- package gnatstub | |
9ffca0cd | 302 | |
dbc3c229 | 303 | "Pgnatstub#" & |
304 | "Ladefault_switches#" & | |
9c0520cb | 305 | "LbOswitches#" & |
9dfe12ae | 306 | |
5b235cdc | 307 | -- package Check |
308 | ||
dbc3c229 | 309 | "Pcheck#" & |
310 | "Ladefault_switches#" & | |
9c0520cb | 311 | "LbOswitches#" & |
5b235cdc | 312 | |
79879aee | 313 | -- package Synchronize |
314 | ||
315 | "Psynchronize#" & | |
316 | "Ladefault_switches#" & | |
9c0520cb | 317 | "LbOswitches#" & |
79879aee | 318 | |
9dfe12ae | 319 | -- package Eliminate |
320 | ||
dbc3c229 | 321 | "Peliminate#" & |
322 | "Ladefault_switches#" & | |
9c0520cb | 323 | "LbOswitches#" & |
9ffca0cd | 324 | |
e2aa7314 | 325 | -- package Metrics |
326 | ||
dbc3c229 | 327 | "Pmetrics#" & |
328 | "Ladefault_switches#" & | |
9c0520cb | 329 | "LbOswitches#" & |
e2aa7314 | 330 | |
f15731c4 | 331 | -- package Ide |
332 | ||
dbc3c229 | 333 | "Pide#" & |
334 | "Ladefault_switches#" & | |
335 | "SVremote_host#" & | |
336 | "SVprogram_host#" & | |
337 | "SVcommunication_protocol#" & | |
338 | "Sacompiler_command#" & | |
339 | "SVdebugger_command#" & | |
340 | "SVgnatlist#" & | |
341 | "SVvcs_kind#" & | |
342 | "SVvcs_file_check#" & | |
343 | "SVvcs_log_check#" & | |
7e9e8bc8 | 344 | "SVdocumentation_dir#" & |
f15731c4 | 345 | |
b1f18479 | 346 | -- package Stack |
347 | ||
dbc3c229 | 348 | "Pstack#" & |
349 | "LVswitches#" & | |
9080eb6b | 350 | |
dbc3c229 | 351 | "#"; |
49d882a7 | 352 | |
8f71d067 | 353 | Initialized : Boolean := False; |
354 | -- A flag to avoid multiple initialization | |
355 | ||
79879aee | 356 | Package_Names : String_List_Access := new Strings.String_List (1 .. 20); |
357 | Last_Package_Name : Natural := 0; | |
358 | -- Package_Names (1 .. Last_Package_Name) contains the list of the known | |
359 | -- package names, coming from the Initialization_Data string or from | |
360 | -- calls to one of the two procedures Register_New_Package. | |
361 | ||
362 | procedure Add_Package_Name (Name : String); | |
363 | -- Add a package name in the Package_Name list, extending it, if necessary | |
364 | ||
8f71d067 | 365 | function Name_Id_Of (Name : String) return Name_Id; |
366 | -- Returns the Name_Id for Name in lower case | |
367 | ||
79879aee | 368 | ---------------------- |
369 | -- Add_Package_Name -- | |
370 | ---------------------- | |
371 | ||
372 | procedure Add_Package_Name (Name : String) is | |
373 | begin | |
374 | if Last_Package_Name = Package_Names'Last then | |
375 | declare | |
376 | New_List : constant Strings.String_List_Access := | |
377 | new Strings.String_List (1 .. Package_Names'Last * 2); | |
378 | begin | |
379 | New_List (Package_Names'Range) := Package_Names.all; | |
380 | Package_Names := New_List; | |
381 | end; | |
382 | end if; | |
383 | ||
384 | Last_Package_Name := Last_Package_Name + 1; | |
385 | Package_Names (Last_Package_Name) := new String'(Name); | |
386 | end Add_Package_Name; | |
387 | ||
8f71d067 | 388 | ----------------------- |
389 | -- Attribute_Kind_Of -- | |
390 | ----------------------- | |
391 | ||
392 | function Attribute_Kind_Of | |
393 | (Attribute : Attribute_Node_Id) return Attribute_Kind | |
394 | is | |
395 | begin | |
396 | if Attribute = Empty_Attribute then | |
397 | return Unknown; | |
398 | else | |
399 | return Attrs.Table (Attribute.Value).Attr_Kind; | |
400 | end if; | |
401 | end Attribute_Kind_Of; | |
402 | ||
403 | ----------------------- | |
404 | -- Attribute_Name_Of -- | |
405 | ----------------------- | |
406 | ||
407 | function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is | |
408 | begin | |
409 | if Attribute = Empty_Attribute then | |
410 | return No_Name; | |
411 | else | |
412 | return Attrs.Table (Attribute.Value).Name; | |
413 | end if; | |
414 | end Attribute_Name_Of; | |
415 | ||
416 | -------------------------- | |
417 | -- Attribute_Node_Id_Of -- | |
418 | -------------------------- | |
419 | ||
420 | function Attribute_Node_Id_Of | |
421 | (Name : Name_Id; | |
422 | Starting_At : Attribute_Node_Id) return Attribute_Node_Id | |
423 | is | |
424 | Id : Attr_Node_Id := Starting_At.Value; | |
44d43e97 | 425 | |
8f71d067 | 426 | begin |
427 | while Id /= Empty_Attr | |
428 | and then Attrs.Table (Id).Name /= Name | |
429 | loop | |
430 | Id := Attrs.Table (Id).Next; | |
431 | end loop; | |
432 | ||
433 | return (Value => Id); | |
434 | end Attribute_Node_Id_Of; | |
435 | ||
49d882a7 | 436 | ---------------- |
437 | -- Initialize -- | |
438 | ---------------- | |
439 | ||
440 | procedure Initialize is | |
8f71d067 | 441 | Start : Positive := Initialization_Data'First; |
442 | Finish : Positive := Start; | |
443 | Current_Package : Pkg_Node_Id := Empty_Pkg; | |
444 | Current_Attribute : Attr_Node_Id := Empty_Attr; | |
445 | Is_An_Attribute : Boolean := False; | |
446 | Var_Kind : Variable_Kind := Undefined; | |
447 | Optional_Index : Boolean := False; | |
dbc3c229 | 448 | Attr_Kind : Attribute_Kind := Single; |
8f71d067 | 449 | Package_Name : Name_Id := No_Name; |
450 | Attribute_Name : Name_Id := No_Name; | |
451 | First_Attribute : Attr_Node_Id := Attr.First_Attribute; | |
dbc3c229 | 452 | Read_Only : Boolean; |
9c0520cb | 453 | Others_Allowed : Boolean; |
8f71d067 | 454 | |
455 | function Attribute_Location return String; | |
456 | -- Returns a string depending if we are in the project level attributes | |
457 | -- or in the attributes of a package. | |
458 | ||
459 | ------------------------ | |
460 | -- Attribute_Location -- | |
461 | ------------------------ | |
462 | ||
463 | function Attribute_Location return String is | |
464 | begin | |
465 | if Package_Name = No_Name then | |
466 | return "project level attributes"; | |
467 | ||
468 | else | |
469 | return "attribute of package """ & | |
470 | Get_Name_String (Package_Name) & """"; | |
471 | end if; | |
472 | end Attribute_Location; | |
473 | ||
474 | -- Start of processing for Initialize | |
49d882a7 | 475 | |
432136f2 | 476 | begin |
8f71d067 | 477 | -- Don't allow Initialize action to be repeated |
478 | ||
479 | if Initialized then | |
480 | return; | |
481 | end if; | |
482 | ||
49d882a7 | 483 | -- Make sure the two tables are empty |
484 | ||
8f71d067 | 485 | Attrs.Init; |
9dfe12ae | 486 | Package_Attributes.Init; |
49d882a7 | 487 | |
9ffca0cd | 488 | while Initialization_Data (Start) /= '#' loop |
49d882a7 | 489 | Is_An_Attribute := True; |
9ffca0cd | 490 | case Initialization_Data (Start) is |
49d882a7 | 491 | when 'P' => |
432136f2 | 492 | |
49d882a7 | 493 | -- New allowed package |
432136f2 | 494 | |
49d882a7 | 495 | Start := Start + 1; |
432136f2 | 496 | |
49d882a7 | 497 | Finish := Start; |
9ffca0cd | 498 | while Initialization_Data (Finish) /= '#' loop |
49d882a7 | 499 | Finish := Finish + 1; |
500 | end loop; | |
432136f2 | 501 | |
8f71d067 | 502 | Package_Name := |
503 | Name_Id_Of (Initialization_Data (Start .. Finish - 1)); | |
432136f2 | 504 | |
8f71d067 | 505 | for Index in First_Package .. Package_Attributes.Last loop |
49d882a7 | 506 | if Package_Name = Package_Attributes.Table (Index).Name then |
38d2fa31 | 507 | Osint.Fail ("duplicate name """ |
508 | & Initialization_Data (Start .. Finish - 1) | |
509 | & """ in predefined packages."); | |
49d882a7 | 510 | end if; |
511 | end loop; | |
512 | ||
513 | Is_An_Attribute := False; | |
8f71d067 | 514 | Current_Attribute := Empty_Attr; |
49d882a7 | 515 | Package_Attributes.Increment_Last; |
516 | Current_Package := Package_Attributes.Last; | |
8f71d067 | 517 | Package_Attributes.Table (Current_Package) := |
dbc3c229 | 518 | (Name => Package_Name, |
519 | Known => True, | |
520 | First_Attribute => Empty_Attr); | |
49d882a7 | 521 | Start := Finish + 1; |
432136f2 | 522 | |
79879aee | 523 | Add_Package_Name (Get_Name_String (Package_Name)); |
524 | ||
49d882a7 | 525 | when 'S' => |
8f71d067 | 526 | Var_Kind := Single; |
1bbc9831 | 527 | Optional_Index := False; |
528 | ||
529 | when 's' => | |
8f71d067 | 530 | Var_Kind := Single; |
1bbc9831 | 531 | Optional_Index := True; |
432136f2 | 532 | |
49d882a7 | 533 | when 'L' => |
8f71d067 | 534 | Var_Kind := List; |
1bbc9831 | 535 | Optional_Index := False; |
536 | ||
537 | when 'l' => | |
8f71d067 | 538 | Var_Kind := List; |
1bbc9831 | 539 | Optional_Index := True; |
432136f2 | 540 | |
49d882a7 | 541 | when others => |
542 | raise Program_Error; | |
543 | end case; | |
544 | ||
545 | if Is_An_Attribute then | |
432136f2 | 546 | |
49d882a7 | 547 | -- New attribute |
432136f2 | 548 | |
49d882a7 | 549 | Start := Start + 1; |
9ffca0cd | 550 | case Initialization_Data (Start) is |
49d882a7 | 551 | when 'V' => |
8f71d067 | 552 | Attr_Kind := Single; |
9dfe12ae | 553 | |
49d882a7 | 554 | when 'A' => |
8f71d067 | 555 | Attr_Kind := Associative_Array; |
9dfe12ae | 556 | |
42f613d5 | 557 | when 'a' => |
8f71d067 | 558 | Attr_Kind := Case_Insensitive_Associative_Array; |
9dfe12ae | 559 | |
560 | when 'b' => | |
44d43e97 | 561 | if Osint.File_Names_Case_Sensitive then |
8f71d067 | 562 | Attr_Kind := Associative_Array; |
9dfe12ae | 563 | else |
8f71d067 | 564 | Attr_Kind := Case_Insensitive_Associative_Array; |
9dfe12ae | 565 | end if; |
566 | ||
1bbc9831 | 567 | when 'c' => |
44d43e97 | 568 | if Osint.File_Names_Case_Sensitive then |
8f71d067 | 569 | Attr_Kind := Optional_Index_Associative_Array; |
1bbc9831 | 570 | else |
8f71d067 | 571 | Attr_Kind := |
1bbc9831 | 572 | Optional_Index_Case_Insensitive_Associative_Array; |
573 | end if; | |
574 | ||
49d882a7 | 575 | when others => |
576 | raise Program_Error; | |
577 | end case; | |
432136f2 | 578 | |
49d882a7 | 579 | Start := Start + 1; |
dbc3c229 | 580 | |
9c0520cb | 581 | Read_Only := False; |
582 | Others_Allowed := False; | |
583 | ||
dbc3c229 | 584 | if Initialization_Data (Start) = 'R' then |
585 | Read_Only := True; | |
586 | Start := Start + 1; | |
587 | ||
9c0520cb | 588 | elsif Initialization_Data (Start) = 'O' then |
589 | Others_Allowed := True; | |
590 | Start := Start + 1; | |
dbc3c229 | 591 | end if; |
592 | ||
49d882a7 | 593 | Finish := Start; |
432136f2 | 594 | |
9ffca0cd | 595 | while Initialization_Data (Finish) /= '#' loop |
49d882a7 | 596 | Finish := Finish + 1; |
597 | end loop; | |
432136f2 | 598 | |
8f71d067 | 599 | Attribute_Name := |
600 | Name_Id_Of (Initialization_Data (Start .. Finish - 1)); | |
601 | Attrs.Increment_Last; | |
1bbc9831 | 602 | |
8f71d067 | 603 | if Current_Attribute = Empty_Attr then |
604 | First_Attribute := Attrs.Last; | |
432136f2 | 605 | |
8f71d067 | 606 | if Current_Package /= Empty_Pkg then |
49d882a7 | 607 | Package_Attributes.Table (Current_Package).First_Attribute |
8f71d067 | 608 | := Attrs.Last; |
49d882a7 | 609 | end if; |
432136f2 | 610 | |
49d882a7 | 611 | else |
612 | -- Check that there are no duplicate attributes | |
432136f2 | 613 | |
8f71d067 | 614 | for Index in First_Attribute .. Attrs.Last - 1 loop |
615 | if Attribute_Name = Attrs.Table (Index).Name then | |
38d2fa31 | 616 | Osint.Fail ("duplicate attribute """ |
617 | & Initialization_Data (Start .. Finish - 1) | |
618 | & """ in " & Attribute_Location); | |
49d882a7 | 619 | end if; |
620 | end loop; | |
432136f2 | 621 | |
8f71d067 | 622 | Attrs.Table (Current_Attribute).Next := |
623 | Attrs.Last; | |
49d882a7 | 624 | end if; |
432136f2 | 625 | |
8f71d067 | 626 | Current_Attribute := Attrs.Last; |
627 | Attrs.Table (Current_Attribute) := | |
1bbc9831 | 628 | (Name => Attribute_Name, |
8f71d067 | 629 | Var_Kind => Var_Kind, |
1bbc9831 | 630 | Optional_Index => Optional_Index, |
8f71d067 | 631 | Attr_Kind => Attr_Kind, |
dbc3c229 | 632 | Read_Only => Read_Only, |
9c0520cb | 633 | Others_Allowed => Others_Allowed, |
8f71d067 | 634 | Next => Empty_Attr); |
49d882a7 | 635 | Start := Finish + 1; |
636 | end if; | |
637 | end loop; | |
8f71d067 | 638 | |
639 | Initialized := True; | |
49d882a7 | 640 | end Initialize; |
641 | ||
dbc3c229 | 642 | ------------------ |
643 | -- Is_Read_Only -- | |
644 | ------------------ | |
645 | ||
646 | function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is | |
647 | begin | |
648 | return Attrs.Table (Attribute.Value).Read_Only; | |
649 | end Is_Read_Only; | |
650 | ||
8f71d067 | 651 | ---------------- |
652 | -- Name_Id_Of -- | |
653 | ---------------- | |
654 | ||
655 | function Name_Id_Of (Name : String) return Name_Id is | |
656 | begin | |
657 | Name_Len := 0; | |
658 | Add_Str_To_Name_Buffer (Name); | |
659 | To_Lower (Name_Buffer (1 .. Name_Len)); | |
660 | return Name_Find; | |
661 | end Name_Id_Of; | |
662 | ||
663 | -------------------- | |
664 | -- Next_Attribute -- | |
665 | -------------------- | |
666 | ||
667 | function Next_Attribute | |
668 | (After : Attribute_Node_Id) return Attribute_Node_Id | |
669 | is | |
670 | begin | |
671 | if After = Empty_Attribute then | |
672 | return Empty_Attribute; | |
673 | else | |
674 | return (Value => Attrs.Table (After.Value).Next); | |
675 | end if; | |
676 | end Next_Attribute; | |
677 | ||
678 | ----------------------- | |
679 | -- Optional_Index_Of -- | |
680 | ----------------------- | |
681 | ||
682 | function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is | |
683 | begin | |
684 | if Attribute = Empty_Attribute then | |
685 | return False; | |
686 | else | |
687 | return Attrs.Table (Attribute.Value).Optional_Index; | |
688 | end if; | |
689 | end Optional_Index_Of; | |
690 | ||
9c0520cb | 691 | function Others_Allowed_For |
692 | (Attribute : Attribute_Node_Id) return Boolean | |
693 | is | |
694 | begin | |
695 | if Attribute = Empty_Attribute then | |
696 | return False; | |
697 | else | |
698 | return Attrs.Table (Attribute.Value).Others_Allowed; | |
699 | end if; | |
700 | end Others_Allowed_For; | |
701 | ||
79879aee | 702 | ----------------------- |
703 | -- Package_Name_List -- | |
704 | ----------------------- | |
705 | ||
706 | function Package_Name_List return Strings.String_List is | |
707 | begin | |
708 | return Package_Names (1 .. Last_Package_Name); | |
709 | end Package_Name_List; | |
710 | ||
8f71d067 | 711 | ------------------------ |
712 | -- Package_Node_Id_Of -- | |
713 | ------------------------ | |
714 | ||
715 | function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is | |
716 | begin | |
717 | for Index in Package_Attributes.First .. Package_Attributes.Last loop | |
718 | if Package_Attributes.Table (Index).Name = Name then | |
0cd59c11 | 719 | if Package_Attributes.Table (Index).Known then |
720 | return (Value => Index); | |
721 | else | |
722 | return Unknown_Package; | |
723 | end if; | |
8f71d067 | 724 | end if; |
725 | end loop; | |
726 | ||
727 | -- If there is no package with this name, return Empty_Package | |
728 | ||
729 | return Empty_Package; | |
730 | end Package_Node_Id_Of; | |
731 | ||
732 | ---------------------------- | |
733 | -- Register_New_Attribute -- | |
734 | ---------------------------- | |
735 | ||
736 | procedure Register_New_Attribute | |
737 | (Name : String; | |
738 | In_Package : Package_Node_Id; | |
739 | Attr_Kind : Defined_Attribute_Kind; | |
740 | Var_Kind : Defined_Variable_Kind; | |
741 | Index_Is_File_Name : Boolean := False; | |
742 | Opt_Index : Boolean := False) | |
743 | is | |
744 | Attr_Name : Name_Id; | |
745 | First_Attr : Attr_Node_Id := Empty_Attr; | |
746 | Curr_Attr : Attr_Node_Id; | |
747 | Real_Attr_Kind : Attribute_Kind; | |
748 | ||
749 | begin | |
750 | if Name'Length = 0 then | |
751 | Fail ("cannot register an attribute with no name"); | |
44d43e97 | 752 | raise Project_Error; |
8f71d067 | 753 | end if; |
754 | ||
755 | if In_Package = Empty_Package then | |
38d2fa31 | 756 | Fail ("attempt to add attribute """ |
757 | & Name | |
758 | & """ to an undefined package"); | |
44d43e97 | 759 | raise Project_Error; |
8f71d067 | 760 | end if; |
761 | ||
762 | Attr_Name := Name_Id_Of (Name); | |
763 | ||
764 | First_Attr := | |
765 | Package_Attributes.Table (In_Package.Value).First_Attribute; | |
766 | ||
767 | -- Check if attribute name is a duplicate | |
768 | ||
769 | Curr_Attr := First_Attr; | |
770 | while Curr_Attr /= Empty_Attr loop | |
771 | if Attrs.Table (Curr_Attr).Name = Attr_Name then | |
38d2fa31 | 772 | Fail ("duplicate attribute name """ |
773 | & Name | |
774 | & """ in package """ | |
775 | & Get_Name_String | |
776 | (Package_Attributes.Table (In_Package.Value).Name) | |
777 | & """"); | |
44d43e97 | 778 | raise Project_Error; |
8f71d067 | 779 | end if; |
780 | ||
781 | Curr_Attr := Attrs.Table (Curr_Attr).Next; | |
782 | end loop; | |
783 | ||
784 | Real_Attr_Kind := Attr_Kind; | |
785 | ||
786 | -- If Index_Is_File_Name, change the attribute kind if necessary | |
787 | ||
44d43e97 | 788 | if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then |
8f71d067 | 789 | case Attr_Kind is |
790 | when Associative_Array => | |
791 | Real_Attr_Kind := Case_Insensitive_Associative_Array; | |
792 | ||
793 | when Optional_Index_Associative_Array => | |
794 | Real_Attr_Kind := | |
795 | Optional_Index_Case_Insensitive_Associative_Array; | |
796 | ||
797 | when others => | |
798 | null; | |
799 | end case; | |
800 | end if; | |
801 | ||
802 | -- Add the new attribute | |
803 | ||
804 | Attrs.Increment_Last; | |
805 | Attrs.Table (Attrs.Last) := | |
806 | (Name => Attr_Name, | |
807 | Var_Kind => Var_Kind, | |
808 | Optional_Index => Opt_Index, | |
809 | Attr_Kind => Real_Attr_Kind, | |
dbc3c229 | 810 | Read_Only => False, |
9c0520cb | 811 | Others_Allowed => False, |
8f71d067 | 812 | Next => First_Attr); |
0cd59c11 | 813 | |
8f71d067 | 814 | Package_Attributes.Table (In_Package.Value).First_Attribute := |
815 | Attrs.Last; | |
816 | end Register_New_Attribute; | |
817 | ||
818 | -------------------------- | |
819 | -- Register_New_Package -- | |
820 | -------------------------- | |
821 | ||
822 | procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is | |
44d43e97 | 823 | Pkg_Name : Name_Id; |
8f71d067 | 824 | |
825 | begin | |
826 | if Name'Length = 0 then | |
827 | Fail ("cannot register a package with no name"); | |
44d43e97 | 828 | Id := Empty_Package; |
829 | return; | |
8f71d067 | 830 | end if; |
831 | ||
832 | Pkg_Name := Name_Id_Of (Name); | |
44d43e97 | 833 | |
834 | for Index in Package_Attributes.First .. Package_Attributes.Last loop | |
835 | if Package_Attributes.Table (Index).Name = Pkg_Name then | |
38d2fa31 | 836 | Fail ("cannot register a package with a non unique name""" |
837 | & Name | |
838 | & """"); | |
44d43e97 | 839 | Id := Empty_Package; |
840 | return; | |
841 | end if; | |
842 | end loop; | |
843 | ||
8f71d067 | 844 | Package_Attributes.Increment_Last; |
845 | Id := (Value => Package_Attributes.Last); | |
846 | Package_Attributes.Table (Package_Attributes.Last) := | |
dbc3c229 | 847 | (Name => Pkg_Name, |
848 | Known => True, | |
849 | First_Attribute => Empty_Attr); | |
79879aee | 850 | |
851 | Add_Package_Name (Get_Name_String (Pkg_Name)); | |
8f71d067 | 852 | end Register_New_Package; |
853 | ||
854 | procedure Register_New_Package | |
855 | (Name : String; | |
856 | Attributes : Attribute_Data_Array) | |
857 | is | |
858 | Pkg_Name : Name_Id; | |
859 | Attr_Name : Name_Id; | |
860 | First_Attr : Attr_Node_Id := Empty_Attr; | |
861 | Curr_Attr : Attr_Node_Id; | |
862 | Attr_Kind : Attribute_Kind; | |
863 | ||
864 | begin | |
865 | if Name'Length = 0 then | |
866 | Fail ("cannot register a package with no name"); | |
44d43e97 | 867 | raise Project_Error; |
8f71d067 | 868 | end if; |
869 | ||
870 | Pkg_Name := Name_Id_Of (Name); | |
871 | ||
872 | for Index in Package_Attributes.First .. Package_Attributes.Last loop | |
873 | if Package_Attributes.Table (Index).Name = Pkg_Name then | |
38d2fa31 | 874 | Fail ("cannot register a package with a non unique name""" |
875 | & Name | |
876 | & """"); | |
44d43e97 | 877 | raise Project_Error; |
8f71d067 | 878 | end if; |
879 | end loop; | |
880 | ||
881 | for Index in Attributes'Range loop | |
882 | Attr_Name := Name_Id_Of (Attributes (Index).Name); | |
883 | ||
884 | Curr_Attr := First_Attr; | |
885 | while Curr_Attr /= Empty_Attr loop | |
886 | if Attrs.Table (Curr_Attr).Name = Attr_Name then | |
38d2fa31 | 887 | Fail ("duplicate attribute name """ |
888 | & Attributes (Index).Name | |
889 | & """ in new package """ | |
890 | & Name | |
891 | & """"); | |
44d43e97 | 892 | raise Project_Error; |
8f71d067 | 893 | end if; |
894 | ||
895 | Curr_Attr := Attrs.Table (Curr_Attr).Next; | |
896 | end loop; | |
897 | ||
898 | Attr_Kind := Attributes (Index).Attr_Kind; | |
899 | ||
900 | if Attributes (Index).Index_Is_File_Name | |
44d43e97 | 901 | and then not Osint.File_Names_Case_Sensitive |
8f71d067 | 902 | then |
903 | case Attr_Kind is | |
904 | when Associative_Array => | |
905 | Attr_Kind := Case_Insensitive_Associative_Array; | |
906 | ||
907 | when Optional_Index_Associative_Array => | |
908 | Attr_Kind := | |
909 | Optional_Index_Case_Insensitive_Associative_Array; | |
910 | ||
911 | when others => | |
912 | null; | |
913 | end case; | |
914 | end if; | |
915 | ||
916 | Attrs.Increment_Last; | |
917 | Attrs.Table (Attrs.Last) := | |
918 | (Name => Attr_Name, | |
919 | Var_Kind => Attributes (Index).Var_Kind, | |
920 | Optional_Index => Attributes (Index).Opt_Index, | |
921 | Attr_Kind => Attr_Kind, | |
dbc3c229 | 922 | Read_Only => False, |
9c0520cb | 923 | Others_Allowed => False, |
8f71d067 | 924 | Next => First_Attr); |
925 | First_Attr := Attrs.Last; | |
926 | end loop; | |
927 | ||
928 | Package_Attributes.Increment_Last; | |
929 | Package_Attributes.Table (Package_Attributes.Last) := | |
dbc3c229 | 930 | (Name => Pkg_Name, |
931 | Known => True, | |
932 | First_Attribute => First_Attr); | |
79879aee | 933 | |
934 | Add_Package_Name (Get_Name_String (Pkg_Name)); | |
8f71d067 | 935 | end Register_New_Package; |
936 | ||
937 | --------------------------- | |
938 | -- Set_Attribute_Kind_Of -- | |
939 | --------------------------- | |
940 | ||
941 | procedure Set_Attribute_Kind_Of | |
942 | (Attribute : Attribute_Node_Id; | |
943 | To : Attribute_Kind) | |
944 | is | |
945 | begin | |
946 | if Attribute /= Empty_Attribute then | |
947 | Attrs.Table (Attribute.Value).Attr_Kind := To; | |
948 | end if; | |
949 | end Set_Attribute_Kind_Of; | |
950 | ||
951 | -------------------------- | |
952 | -- Set_Variable_Kind_Of -- | |
953 | -------------------------- | |
954 | ||
955 | procedure Set_Variable_Kind_Of | |
956 | (Attribute : Attribute_Node_Id; | |
957 | To : Variable_Kind) | |
958 | is | |
959 | begin | |
960 | if Attribute /= Empty_Attribute then | |
961 | Attrs.Table (Attribute.Value).Var_Kind := To; | |
962 | end if; | |
963 | end Set_Variable_Kind_Of; | |
964 | ||
965 | ---------------------- | |
966 | -- Variable_Kind_Of -- | |
967 | ---------------------- | |
968 | ||
969 | function Variable_Kind_Of | |
970 | (Attribute : Attribute_Node_Id) return Variable_Kind | |
971 | is | |
972 | begin | |
973 | if Attribute = Empty_Attribute then | |
974 | return Undefined; | |
975 | else | |
976 | return Attrs.Table (Attribute.Value).Var_Kind; | |
977 | end if; | |
978 | end Variable_Kind_Of; | |
979 | ||
980 | ------------------------ | |
981 | -- First_Attribute_Of -- | |
982 | ------------------------ | |
983 | ||
984 | function First_Attribute_Of | |
985 | (Pkg : Package_Node_Id) return Attribute_Node_Id | |
986 | is | |
987 | begin | |
988 | if Pkg = Empty_Package then | |
989 | return Empty_Attribute; | |
990 | else | |
991 | return | |
992 | (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); | |
993 | end if; | |
994 | end First_Attribute_Of; | |
995 | ||
49d882a7 | 996 | end Prj.Attr; |