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