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