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