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