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