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