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-2015, 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 -- package Codepeer 383 384 "Pcodepeer#" & 385 "SVoutput_directory#" & 386 "SVdatabase_directory#" & 387 "SVmessage_patterns#" & 388 "SVadditional_patterns#" & 389 "LVswitches#" & 390 "LVexcluded_source_files#" & 391 392 -- package Prove 393 394 "Pprove#" & 395 396 -- package GnatTest 397 398 "Pgnattest#" & 399 400 "#"; 401 402 Initialized : Boolean := False; 403 -- A flag to avoid multiple initialization 404 405 Package_Names : String_List_Access := new Strings.String_List (1 .. 20); 406 Last_Package_Name : Natural := 0; 407 -- Package_Names (1 .. Last_Package_Name) contains the list of the known 408 -- package names, coming from the Initialization_Data string or from 409 -- calls to one of the two procedures Register_New_Package. 410 411 procedure Add_Package_Name (Name : String); 412 -- Add a package name in the Package_Name list, extending it, if necessary 413 414 function Name_Id_Of (Name : String) return Name_Id; 415 -- Returns the Name_Id for Name in lower case 416 417 ---------------------- 418 -- Add_Package_Name -- 419 ---------------------- 420 421 procedure Add_Package_Name (Name : String) is 422 begin 423 if Last_Package_Name = Package_Names'Last then 424 declare 425 New_List : constant Strings.String_List_Access := 426 new Strings.String_List (1 .. Package_Names'Last * 2); 427 begin 428 New_List (Package_Names'Range) := Package_Names.all; 429 Package_Names := New_List; 430 end; 431 end if; 432 433 Last_Package_Name := Last_Package_Name + 1; 434 Package_Names (Last_Package_Name) := new String'(Name); 435 end Add_Package_Name; 436 437 -------------------------- 438 -- Attribute_Default_Of -- 439 -------------------------- 440 441 function Attribute_Default_Of 442 (Attribute : Attribute_Node_Id) return Attribute_Default_Value 443 is 444 begin 445 if Attribute = Empty_Attribute then 446 return Empty_Value; 447 else 448 return Attrs.Table (Attribute.Value).Default; 449 end if; 450 end Attribute_Default_Of; 451 452 ----------------------- 453 -- Attribute_Kind_Of -- 454 ----------------------- 455 456 function Attribute_Kind_Of 457 (Attribute : Attribute_Node_Id) return Attribute_Kind 458 is 459 begin 460 if Attribute = Empty_Attribute then 461 return Unknown; 462 else 463 return Attrs.Table (Attribute.Value).Attr_Kind; 464 end if; 465 end Attribute_Kind_Of; 466 467 ----------------------- 468 -- Attribute_Name_Of -- 469 ----------------------- 470 471 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is 472 begin 473 if Attribute = Empty_Attribute then 474 return No_Name; 475 else 476 return Attrs.Table (Attribute.Value).Name; 477 end if; 478 end Attribute_Name_Of; 479 480 -------------------------- 481 -- Attribute_Node_Id_Of -- 482 -------------------------- 483 484 function Attribute_Node_Id_Of 485 (Name : Name_Id; 486 Starting_At : Attribute_Node_Id) return Attribute_Node_Id 487 is 488 Id : Attr_Node_Id := Starting_At.Value; 489 490 begin 491 while Id /= Empty_Attr 492 and then Attrs.Table (Id).Name /= Name 493 loop 494 Id := Attrs.Table (Id).Next; 495 end loop; 496 497 return (Value => Id); 498 end Attribute_Node_Id_Of; 499 500 ---------------- 501 -- Initialize -- 502 ---------------- 503 504 procedure Initialize is 505 Start : Positive := Initialization_Data'First; 506 Finish : Positive := Start; 507 Current_Package : Pkg_Node_Id := Empty_Pkg; 508 Current_Attribute : Attr_Node_Id := Empty_Attr; 509 Is_An_Attribute : Boolean := False; 510 Var_Kind : Variable_Kind := Undefined; 511 Optional_Index : Boolean := False; 512 Attr_Kind : Attribute_Kind := Single; 513 Package_Name : Name_Id := No_Name; 514 Attribute_Name : Name_Id := No_Name; 515 First_Attribute : Attr_Node_Id := Attr.First_Attribute; 516 Read_Only : Boolean; 517 Others_Allowed : Boolean; 518 Default : Attribute_Default_Value; 519 520 function Attribute_Location return String; 521 -- Returns a string depending if we are in the project level attributes 522 -- or in the attributes of a package. 523 524 ------------------------ 525 -- Attribute_Location -- 526 ------------------------ 527 528 function Attribute_Location return String is 529 begin 530 if Package_Name = No_Name then 531 return "project level attributes"; 532 533 else 534 return "attribute of package """ & 535 Get_Name_String (Package_Name) & """"; 536 end if; 537 end Attribute_Location; 538 539 -- Start of processing for Initialize 540 541 begin 542 -- Don't allow Initialize action to be repeated 543 544 if Initialized then 545 return; 546 end if; 547 548 -- Make sure the two tables are empty 549 550 Attrs.Init; 551 Package_Attributes.Init; 552 553 while Initialization_Data (Start) /= '#' loop 554 Is_An_Attribute := True; 555 case Initialization_Data (Start) is 556 when 'P' => 557 558 -- New allowed package 559 560 Start := Start + 1; 561 562 Finish := Start; 563 while Initialization_Data (Finish) /= '#' loop 564 Finish := Finish + 1; 565 end loop; 566 567 Package_Name := 568 Name_Id_Of (Initialization_Data (Start .. Finish - 1)); 569 570 for Index in First_Package .. Package_Attributes.Last loop 571 if Package_Name = Package_Attributes.Table (Index).Name then 572 Osint.Fail ("duplicate name """ 573 & Initialization_Data (Start .. Finish - 1) 574 & """ in predefined packages."); 575 end if; 576 end loop; 577 578 Is_An_Attribute := False; 579 Current_Attribute := Empty_Attr; 580 Package_Attributes.Increment_Last; 581 Current_Package := Package_Attributes.Last; 582 Package_Attributes.Table (Current_Package) := 583 (Name => Package_Name, 584 Known => True, 585 First_Attribute => Empty_Attr); 586 Start := Finish + 1; 587 588 Add_Package_Name (Get_Name_String (Package_Name)); 589 590 when 'S' => 591 Var_Kind := Single; 592 Optional_Index := False; 593 594 when 's' => 595 Var_Kind := Single; 596 Optional_Index := True; 597 598 when 'L' => 599 Var_Kind := List; 600 Optional_Index := False; 601 602 when 'l' => 603 Var_Kind := List; 604 Optional_Index := True; 605 606 when others => 607 raise Program_Error; 608 end case; 609 610 if Is_An_Attribute then 611 612 -- New attribute 613 614 Start := Start + 1; 615 case Initialization_Data (Start) is 616 when 'V' => 617 Attr_Kind := Single; 618 619 when 'A' => 620 Attr_Kind := Associative_Array; 621 622 when 'a' => 623 Attr_Kind := Case_Insensitive_Associative_Array; 624 625 when 'b' => 626 if Osint.File_Names_Case_Sensitive then 627 Attr_Kind := Associative_Array; 628 else 629 Attr_Kind := Case_Insensitive_Associative_Array; 630 end if; 631 632 when 'c' => 633 if Osint.File_Names_Case_Sensitive then 634 Attr_Kind := Optional_Index_Associative_Array; 635 else 636 Attr_Kind := 637 Optional_Index_Case_Insensitive_Associative_Array; 638 end if; 639 640 when others => 641 raise Program_Error; 642 end case; 643 644 Start := Start + 1; 645 646 Read_Only := False; 647 Others_Allowed := False; 648 Default := Empty_Value; 649 650 if Initialization_Data (Start) = 'R' then 651 Read_Only := True; 652 Default := Read_Only_Value; 653 Start := Start + 1; 654 655 elsif Initialization_Data (Start) = 'O' then 656 Others_Allowed := True; 657 Start := Start + 1; 658 end if; 659 660 Finish := Start; 661 662 while Initialization_Data (Finish) /= '#' 663 and then 664 Initialization_Data (Finish) /= 'D' 665 loop 666 Finish := Finish + 1; 667 end loop; 668 669 Attribute_Name := 670 Name_Id_Of (Initialization_Data (Start .. Finish - 1)); 671 672 if Initialization_Data (Finish) = 'D' then 673 Start := Finish + 1; 674 675 Finish := Start; 676 while Initialization_Data (Finish) /= '#' loop 677 Finish := Finish + 1; 678 end loop; 679 680 declare 681 Default_Name : constant String := 682 Initialization_Data (Start .. Finish - 1); 683 pragma Unsuppress (All_Checks); 684 begin 685 Default := Attribute_Default_Value'Value (Default_Name); 686 exception 687 when Constraint_Error => 688 Osint.Fail 689 ("illegal default value """ & 690 Default_Name & 691 """ for attribute " & 692 Get_Name_String (Attribute_Name)); 693 end; 694 end if; 695 696 Attrs.Increment_Last; 697 698 if Current_Attribute = Empty_Attr then 699 First_Attribute := Attrs.Last; 700 701 if Current_Package /= Empty_Pkg then 702 Package_Attributes.Table (Current_Package).First_Attribute 703 := Attrs.Last; 704 end if; 705 706 else 707 -- Check that there are no duplicate attributes 708 709 for Index in First_Attribute .. Attrs.Last - 1 loop 710 if Attribute_Name = Attrs.Table (Index).Name then 711 Osint.Fail ("duplicate attribute """ 712 & Initialization_Data (Start .. Finish - 1) 713 & """ in " & Attribute_Location); 714 end if; 715 end loop; 716 717 Attrs.Table (Current_Attribute).Next := 718 Attrs.Last; 719 end if; 720 721 Current_Attribute := Attrs.Last; 722 Attrs.Table (Current_Attribute) := 723 (Name => Attribute_Name, 724 Var_Kind => Var_Kind, 725 Optional_Index => Optional_Index, 726 Attr_Kind => Attr_Kind, 727 Read_Only => Read_Only, 728 Others_Allowed => Others_Allowed, 729 Default => Default, 730 Next => Empty_Attr); 731 Start := Finish + 1; 732 end if; 733 end loop; 734 735 Initialized := True; 736 end Initialize; 737 738 ------------------ 739 -- Is_Read_Only -- 740 ------------------ 741 742 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is 743 begin 744 return Attrs.Table (Attribute.Value).Read_Only; 745 end Is_Read_Only; 746 747 ---------------- 748 -- Name_Id_Of -- 749 ---------------- 750 751 function Name_Id_Of (Name : String) return Name_Id is 752 begin 753 Name_Len := 0; 754 Add_Str_To_Name_Buffer (Name); 755 To_Lower (Name_Buffer (1 .. Name_Len)); 756 return Name_Find; 757 end Name_Id_Of; 758 759 -------------------- 760 -- Next_Attribute -- 761 -------------------- 762 763 function Next_Attribute 764 (After : Attribute_Node_Id) return Attribute_Node_Id 765 is 766 begin 767 if After = Empty_Attribute then 768 return Empty_Attribute; 769 else 770 return (Value => Attrs.Table (After.Value).Next); 771 end if; 772 end Next_Attribute; 773 774 ----------------------- 775 -- Optional_Index_Of -- 776 ----------------------- 777 778 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is 779 begin 780 if Attribute = Empty_Attribute then 781 return False; 782 else 783 return Attrs.Table (Attribute.Value).Optional_Index; 784 end if; 785 end Optional_Index_Of; 786 787 function Others_Allowed_For 788 (Attribute : Attribute_Node_Id) return Boolean 789 is 790 begin 791 if Attribute = Empty_Attribute then 792 return False; 793 else 794 return Attrs.Table (Attribute.Value).Others_Allowed; 795 end if; 796 end Others_Allowed_For; 797 798 ----------------------- 799 -- Package_Name_List -- 800 ----------------------- 801 802 function Package_Name_List return Strings.String_List is 803 begin 804 return Package_Names (1 .. Last_Package_Name); 805 end Package_Name_List; 806 807 ------------------------ 808 -- Package_Node_Id_Of -- 809 ------------------------ 810 811 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is 812 begin 813 for Index in Package_Attributes.First .. Package_Attributes.Last loop 814 if Package_Attributes.Table (Index).Name = Name then 815 if Package_Attributes.Table (Index).Known then 816 return (Value => Index); 817 else 818 return Unknown_Package; 819 end if; 820 end if; 821 end loop; 822 823 -- If there is no package with this name, return Empty_Package 824 825 return Empty_Package; 826 end Package_Node_Id_Of; 827 828 ---------------------------- 829 -- Register_New_Attribute -- 830 ---------------------------- 831 832 procedure Register_New_Attribute 833 (Name : String; 834 In_Package : Package_Node_Id; 835 Attr_Kind : Defined_Attribute_Kind; 836 Var_Kind : Defined_Variable_Kind; 837 Index_Is_File_Name : Boolean := False; 838 Opt_Index : Boolean := False; 839 Default : Attribute_Default_Value := Empty_Value) 840 is 841 Attr_Name : Name_Id; 842 First_Attr : Attr_Node_Id := Empty_Attr; 843 Curr_Attr : Attr_Node_Id; 844 Real_Attr_Kind : Attribute_Kind; 845 846 begin 847 if Name'Length = 0 then 848 Fail ("cannot register an attribute with no name"); 849 raise Project_Error; 850 end if; 851 852 if In_Package = Empty_Package then 853 Fail ("attempt to add attribute """ 854 & Name 855 & """ to an undefined package"); 856 raise Project_Error; 857 end if; 858 859 Attr_Name := Name_Id_Of (Name); 860 861 First_Attr := 862 Package_Attributes.Table (In_Package.Value).First_Attribute; 863 864 -- Check if attribute name is a duplicate 865 866 Curr_Attr := First_Attr; 867 while Curr_Attr /= Empty_Attr loop 868 if Attrs.Table (Curr_Attr).Name = Attr_Name then 869 Fail ("duplicate attribute name """ 870 & Name 871 & """ in package """ 872 & Get_Name_String 873 (Package_Attributes.Table (In_Package.Value).Name) 874 & """"); 875 raise Project_Error; 876 end if; 877 878 Curr_Attr := Attrs.Table (Curr_Attr).Next; 879 end loop; 880 881 Real_Attr_Kind := Attr_Kind; 882 883 -- If Index_Is_File_Name, change the attribute kind if necessary 884 885 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then 886 case Attr_Kind is 887 when Associative_Array => 888 Real_Attr_Kind := Case_Insensitive_Associative_Array; 889 890 when Optional_Index_Associative_Array => 891 Real_Attr_Kind := 892 Optional_Index_Case_Insensitive_Associative_Array; 893 894 when others => 895 null; 896 end case; 897 end if; 898 899 -- Add the new attribute 900 901 Attrs.Increment_Last; 902 Attrs.Table (Attrs.Last) := 903 (Name => Attr_Name, 904 Var_Kind => Var_Kind, 905 Optional_Index => Opt_Index, 906 Attr_Kind => Real_Attr_Kind, 907 Read_Only => False, 908 Others_Allowed => False, 909 Default => Default, 910 Next => First_Attr); 911 912 Package_Attributes.Table (In_Package.Value).First_Attribute := 913 Attrs.Last; 914 end Register_New_Attribute; 915 916 -------------------------- 917 -- Register_New_Package -- 918 -------------------------- 919 920 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is 921 Pkg_Name : Name_Id; 922 Found : Boolean := False; 923 924 begin 925 if Name'Length = 0 then 926 Fail ("cannot register a package with no name"); 927 Id := Empty_Package; 928 return; 929 end if; 930 931 Pkg_Name := Name_Id_Of (Name); 932 933 for Index in Package_Attributes.First .. Package_Attributes.Last loop 934 if Package_Attributes.Table (Index).Name = Pkg_Name then 935 if Package_Attributes.Table (Index).Known then 936 Fail ("cannot register a package with a non unique name """ 937 & Name 938 & """"); 939 Id := Empty_Package; 940 return; 941 942 else 943 Found := True; 944 Id := (Value => Index); 945 exit; 946 end if; 947 end if; 948 end loop; 949 950 if not Found then 951 Package_Attributes.Increment_Last; 952 Id := (Value => Package_Attributes.Last); 953 end if; 954 955 Package_Attributes.Table (Id.Value) := 956 (Name => Pkg_Name, 957 Known => True, 958 First_Attribute => Empty_Attr); 959 960 Add_Package_Name (Get_Name_String (Pkg_Name)); 961 end Register_New_Package; 962 963 procedure Register_New_Package 964 (Name : String; 965 Attributes : Attribute_Data_Array) 966 is 967 Pkg_Name : Name_Id; 968 Attr_Name : Name_Id; 969 First_Attr : Attr_Node_Id := Empty_Attr; 970 Curr_Attr : Attr_Node_Id; 971 Attr_Kind : Attribute_Kind; 972 973 begin 974 if Name'Length = 0 then 975 Fail ("cannot register a package with no name"); 976 raise Project_Error; 977 end if; 978 979 Pkg_Name := Name_Id_Of (Name); 980 981 for Index in Package_Attributes.First .. Package_Attributes.Last loop 982 if Package_Attributes.Table (Index).Name = Pkg_Name then 983 Fail ("cannot register a package with a non unique name """ 984 & Name 985 & """"); 986 raise Project_Error; 987 end if; 988 end loop; 989 990 for Index in Attributes'Range loop 991 Attr_Name := Name_Id_Of (Attributes (Index).Name); 992 993 Curr_Attr := First_Attr; 994 while Curr_Attr /= Empty_Attr loop 995 if Attrs.Table (Curr_Attr).Name = Attr_Name then 996 Fail ("duplicate attribute name """ 997 & Attributes (Index).Name 998 & """ in new package """ 999 & Name 1000 & """"); 1001 raise Project_Error; 1002 end if; 1003 1004 Curr_Attr := Attrs.Table (Curr_Attr).Next; 1005 end loop; 1006 1007 Attr_Kind := Attributes (Index).Attr_Kind; 1008 1009 if Attributes (Index).Index_Is_File_Name 1010 and then not Osint.File_Names_Case_Sensitive 1011 then 1012 case Attr_Kind is 1013 when Associative_Array => 1014 Attr_Kind := Case_Insensitive_Associative_Array; 1015 1016 when Optional_Index_Associative_Array => 1017 Attr_Kind := 1018 Optional_Index_Case_Insensitive_Associative_Array; 1019 1020 when others => 1021 null; 1022 end case; 1023 end if; 1024 1025 Attrs.Increment_Last; 1026 Attrs.Table (Attrs.Last) := 1027 (Name => Attr_Name, 1028 Var_Kind => Attributes (Index).Var_Kind, 1029 Optional_Index => Attributes (Index).Opt_Index, 1030 Attr_Kind => Attr_Kind, 1031 Read_Only => False, 1032 Others_Allowed => False, 1033 Default => Attributes (Index).Default, 1034 Next => First_Attr); 1035 First_Attr := Attrs.Last; 1036 end loop; 1037 1038 Package_Attributes.Increment_Last; 1039 Package_Attributes.Table (Package_Attributes.Last) := 1040 (Name => Pkg_Name, 1041 Known => True, 1042 First_Attribute => First_Attr); 1043 1044 Add_Package_Name (Get_Name_String (Pkg_Name)); 1045 end Register_New_Package; 1046 1047 --------------------------- 1048 -- Set_Attribute_Kind_Of -- 1049 --------------------------- 1050 1051 procedure Set_Attribute_Kind_Of 1052 (Attribute : Attribute_Node_Id; 1053 To : Attribute_Kind) 1054 is 1055 begin 1056 if Attribute /= Empty_Attribute then 1057 Attrs.Table (Attribute.Value).Attr_Kind := To; 1058 end if; 1059 end Set_Attribute_Kind_Of; 1060 1061 -------------------------- 1062 -- Set_Variable_Kind_Of -- 1063 -------------------------- 1064 1065 procedure Set_Variable_Kind_Of 1066 (Attribute : Attribute_Node_Id; 1067 To : Variable_Kind) 1068 is 1069 begin 1070 if Attribute /= Empty_Attribute then 1071 Attrs.Table (Attribute.Value).Var_Kind := To; 1072 end if; 1073 end Set_Variable_Kind_Of; 1074 1075 ---------------------- 1076 -- Variable_Kind_Of -- 1077 ---------------------- 1078 1079 function Variable_Kind_Of 1080 (Attribute : Attribute_Node_Id) return Variable_Kind 1081 is 1082 begin 1083 if Attribute = Empty_Attribute then 1084 return Undefined; 1085 else 1086 return Attrs.Table (Attribute.Value).Var_Kind; 1087 end if; 1088 end Variable_Kind_Of; 1089 1090 ------------------------ 1091 -- First_Attribute_Of -- 1092 ------------------------ 1093 1094 function First_Attribute_Of 1095 (Pkg : Package_Node_Id) return Attribute_Node_Id 1096 is 1097 begin 1098 if Pkg = Empty_Package or else Pkg = Unknown_Package then 1099 return Empty_Attribute; 1100 else 1101 return 1102 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); 1103 end if; 1104 end First_Attribute_Of; 1105 1106end Prj.Attr; 1107