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