gcc/ada/prj-attr.adb

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