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