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