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