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