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