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