gcc/ada/prj-dect.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . D E C T                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with GNAT.Case_Util;        use GNAT.Case_Util;
  27 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  28 with GNAT.Strings;
  29
  30 with Err_Vars;    use Err_Vars;
  31 with Opt;         use Opt;
  32 with Prj.Attr;    use Prj.Attr;
  33 with Prj.Attr.PM; use Prj.Attr.PM;
  34 with Prj.Err;     use Prj.Err;
  35 with Prj.Strt;    use Prj.Strt;
  36 with Prj.Tree;    use Prj.Tree;
  37 with Snames;
  38 with Uintp;       use Uintp;
  39
  40 package body Prj.Dect is
  41
  42    use GNAT;
  43
  44    type Zone is (In_Project, In_Package, In_Case_Construction);
  45    --  Used to indicate if we are parsing a package (In_Package),
  46    --  a case construction (In_Case_Construction) or none of those two
  47    --  (In_Project).
  48
  49    procedure Rename_Obsolescent_Attributes
  50      (In_Tree         : Project_Node_Tree_Ref;
  51       Attribute       : Project_Node_Id;
  52       Current_Package : Project_Node_Id);
  53    --  Rename obsolescent attributes in the tree.
  54    --  When the attribute has been renamed since its initial introduction in
  55    --  the design of projects, we replace the old name in the tree with the
  56    --  new name, so that the code does not have to check both names forever.
  57
  58    procedure Check_Attribute_Allowed
  59      (In_Tree   : Project_Node_Tree_Ref;
  60       Project   : Project_Node_Id;
  61       Attribute : Project_Node_Id;
  62       Flags     : Processing_Flags);
  63    --  Check whether the attribute is valid in this project.
  64    --  In particular, depending on the type of project (qualifier), some
  65    --  attributes might be disabled.
  66
  67    procedure Check_Package_Allowed
  68      (In_Tree         : Project_Node_Tree_Ref;
  69       Project         : Project_Node_Id;
  70       Current_Package : Project_Node_Id;
  71       Flags           : Processing_Flags);
  72    --  Check whether the package is valid in this project
  73
  74    procedure Parse_Attribute_Declaration
  75      (In_Tree           : Project_Node_Tree_Ref;
  76       Attribute         : out Project_Node_Id;
  77       First_Attribute   : Attribute_Node_Id;
  78       Current_Project   : Project_Node_Id;
  79       Current_Package   : Project_Node_Id;
  80       Packages_To_Check : String_List_Access;
  81       Flags             : Processing_Flags);
  82    --  Parse an attribute declaration
  83
  84    procedure Parse_Case_Construction
  85      (In_Tree           : Project_Node_Tree_Ref;
  86       Case_Construction : out Project_Node_Id;
  87       First_Attribute   : Attribute_Node_Id;
  88       Current_Project   : Project_Node_Id;
  89       Current_Package   : Project_Node_Id;
  90       Packages_To_Check : String_List_Access;
  91       Is_Config_File    : Boolean;
  92       Flags             : Processing_Flags);
  93    --  Parse a case construction
  94
  95    procedure Parse_Declarative_Items
  96      (In_Tree           : Project_Node_Tree_Ref;
  97       Declarations      : out Project_Node_Id;
  98       In_Zone           : Zone;
  99       First_Attribute   : Attribute_Node_Id;
 100       Current_Project   : Project_Node_Id;
 101       Current_Package   : Project_Node_Id;
 102       Packages_To_Check : String_List_Access;
 103       Is_Config_File    : Boolean;
 104       Flags             : Processing_Flags);
 105    --  Parse declarative items. Depending on In_Zone, some declarative items
 106    --  may be forbidden. Is_Config_File should be set to True if the project
 107    --  represents a config file (.cgpr) since some specific checks apply.
 108
 109    procedure Parse_Package_Declaration
 110      (In_Tree             : Project_Node_Tree_Ref;
 111       Package_Declaration : out Project_Node_Id;
 112       Current_Project     : Project_Node_Id;
 113       Packages_To_Check   : String_List_Access;
 114       Is_Config_File      : Boolean;
 115       Flags               : Processing_Flags);
 116    --  Parse a package declaration.
 117    --  Is_Config_File should be set to True if the project represents a config
 118    --  file (.cgpr) since some specific checks apply.
 119
 120    procedure Parse_String_Type_Declaration
 121      (In_Tree         : Project_Node_Tree_Ref;
 122       String_Type     : out Project_Node_Id;
 123       Current_Project : Project_Node_Id;
 124       Flags           : Processing_Flags);
 125    --  type <name> is ( <literal_string> { , <literal_string> } ) ;
 126
 127    procedure Parse_Variable_Declaration
 128      (In_Tree         : Project_Node_Tree_Ref;
 129       Variable        : out Project_Node_Id;
 130       Current_Project : Project_Node_Id;
 131       Current_Package : Project_Node_Id;
 132       Flags           : Processing_Flags);
 133    --  Parse a variable assignment
 134    --  <variable_Name> := <expression>; OR
 135    --  <variable_Name> : <string_type_Name> := <string_expression>;
 136
 137    -----------
 138    -- Parse --
 139    -----------
 140
 141    procedure Parse
 142      (In_Tree           : Project_Node_Tree_Ref;
 143       Declarations      : out Project_Node_Id;
 144       Current_Project   : Project_Node_Id;
 145       Extends           : Project_Node_Id;
 146       Packages_To_Check : String_List_Access;
 147       Is_Config_File    : Boolean;
 148       Flags             : Processing_Flags)
 149    is
 150       First_Declarative_Item : Project_Node_Id := Empty_Node;
 151
 152    begin
 153       Declarations :=
 154         Default_Project_Node
 155           (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
 156       Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
 157       Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
 158       Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
 159       Parse_Declarative_Items
 160         (Declarations      => First_Declarative_Item,
 161          In_Tree           => In_Tree,
 162          In_Zone           => In_Project,
 163          First_Attribute   => Prj.Attr.Attribute_First,
 164          Current_Project   => Current_Project,
 165          Current_Package   => Empty_Node,
 166          Packages_To_Check => Packages_To_Check,
 167          Is_Config_File    => Is_Config_File,
 168          Flags             => Flags);
 169       Set_First_Declarative_Item_Of
 170         (Declarations, In_Tree, To => First_Declarative_Item);
 171    end Parse;
 172
 173    -----------------------------------
 174    -- Rename_Obsolescent_Attributes --
 175    -----------------------------------
 176
 177    procedure Rename_Obsolescent_Attributes
 178      (In_Tree         : Project_Node_Tree_Ref;
 179       Attribute       : Project_Node_Id;
 180       Current_Package : Project_Node_Id)
 181    is
 182    begin
 183       if Present (Current_Package)
 184         and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
 185       then
 186          case Name_Of (Attribute, In_Tree) is
 187             when Snames.Name_Specification =>
 188                Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
 189
 190             when Snames.Name_Specification_Suffix =>
 191                Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
 192
 193             when Snames.Name_Implementation =>
 194                Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
 195
 196             when Snames.Name_Implementation_Suffix =>
 197                Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
 198
 199             when others =>
 200                null;
 201          end case;
 202       end if;
 203    end Rename_Obsolescent_Attributes;
 204
 205    ---------------------------
 206    -- Check_Package_Allowed --
 207    ---------------------------
 208
 209    procedure Check_Package_Allowed
 210      (In_Tree         : Project_Node_Tree_Ref;
 211       Project         : Project_Node_Id;
 212       Current_Package : Project_Node_Id;
 213       Flags           : Processing_Flags)
 214    is
 215       Qualif : constant Project_Qualifier :=
 216                  Project_Qualifier_Of (Project, In_Tree);
 217       Name   : constant Name_Id := Name_Of (Current_Package, In_Tree);
 218    begin
 219       if Qualif = Aggregate
 220         and then Name /= Snames.Name_Builder
 221       then
 222          Error_Msg_Name_1 := Name;
 223          Error_Msg
 224            (Flags,
 225             "package %% is forbidden in aggregate projects",
 226             Location_Of (Current_Package, In_Tree));
 227       end if;
 228    end Check_Package_Allowed;
 229
 230    -----------------------------
 231    -- Check_Attribute_Allowed --
 232    -----------------------------
 233
 234    procedure Check_Attribute_Allowed
 235      (In_Tree   : Project_Node_Tree_Ref;
 236       Project   : Project_Node_Id;
 237       Attribute : Project_Node_Id;
 238       Flags     : Processing_Flags)
 239    is
 240       Qualif : constant Project_Qualifier :=
 241                  Project_Qualifier_Of (Project, In_Tree);
 242       Name   : constant Name_Id := Name_Of (Attribute, In_Tree);
 243
 244    begin
 245       case Qualif is
 246          when Aggregate =>
 247             if Name = Snames.Name_Languages
 248               or else Name = Snames.Name_Source_Files
 249               or else Name = Snames.Name_Source_List_File
 250               or else Name = Snames.Name_Locally_Removed_Files
 251               or else Name = Snames.Name_Excluded_Source_Files
 252               or else Name = Snames.Name_Excluded_Source_List_File
 253               or else Name = Snames.Name_Interfaces
 254               or else Name = Snames.Name_Object_Dir
 255               or else Name = Snames.Name_Exec_Dir
 256               or else Name = Snames.Name_Source_Dirs
 257               or else Name = Snames.Name_Inherit_Source_Path
 258             then
 259                Error_Msg_Name_1 := Name;
 260                Error_Msg
 261                  (Flags,
 262                   "%% is not valid in aggregate projects",
 263                   Location_Of (Attribute, In_Tree));
 264             end if;
 265
 266          when others =>
 267             if Name = Snames.Name_Project_Files
 268               or else Name = Snames.Name_Project_Path
 269               or else Name = Snames.Name_External
 270             then
 271                Error_Msg_Name_1 := Name;
 272                Error_Msg
 273                  (Flags,
 274                   "%% is only valid in aggregate projects",
 275                   Location_Of (Attribute, In_Tree));
 276             end if;
 277       end case;
 278    end Check_Attribute_Allowed;
 279
 280    ---------------------------------
 281    -- Parse_Attribute_Declaration --
 282    ---------------------------------
 283
 284    procedure Parse_Attribute_Declaration
 285      (In_Tree           : Project_Node_Tree_Ref;
 286       Attribute         : out Project_Node_Id;
 287       First_Attribute   : Attribute_Node_Id;
 288       Current_Project   : Project_Node_Id;
 289       Current_Package   : Project_Node_Id;
 290       Packages_To_Check : String_List_Access;
 291       Flags             : Processing_Flags)
 292    is
 293       Current_Attribute      : Attribute_Node_Id := First_Attribute;
 294       Full_Associative_Array : Boolean           := False;
 295       Attribute_Name         : Name_Id           := No_Name;
 296       Optional_Index         : Boolean           := False;
 297       Pkg_Id                 : Package_Node_Id   := Empty_Package;
 298
 299       procedure Process_Attribute_Name;
 300       --  Read the name of the attribute, and check its type
 301
 302       procedure Process_Associative_Array_Index;
 303       --  Read the index of the associative array and check its validity
 304
 305       ----------------------------
 306       -- Process_Attribute_Name --
 307       ----------------------------
 308
 309       procedure Process_Attribute_Name is
 310          Ignore : Boolean;
 311
 312       begin
 313          Attribute_Name := Token_Name;
 314          Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
 315          Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
 316
 317          --  Find the attribute
 318
 319          Current_Attribute :=
 320            Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
 321
 322          --  If the attribute cannot be found, create the attribute if inside
 323          --  an unknown package.
 324
 325          if Current_Attribute = Empty_Attribute then
 326             if Present (Current_Package)
 327               and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
 328             then
 329                Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
 330                Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
 331
 332             else
 333                --  If not a valid attribute name, issue an error if inside
 334                --  a package that need to be checked.
 335
 336                Ignore := Present (Current_Package) and then
 337                           Packages_To_Check /= All_Packages;
 338
 339                if Ignore then
 340
 341                   --  Check that we are not in a package to check
 342
 343                   Get_Name_String (Name_Of (Current_Package, In_Tree));
 344
 345                   for Index in Packages_To_Check'Range loop
 346                      if Name_Buffer (1 .. Name_Len) =
 347                        Packages_To_Check (Index).all
 348                      then
 349                         Ignore := False;
 350                         exit;
 351                      end if;
 352                   end loop;
 353                end if;
 354
 355                if not Ignore then
 356                   Error_Msg_Name_1 := Token_Name;
 357                   Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
 358                end if;
 359             end if;
 360
 361          --  Set, if appropriate the index case insensitivity flag
 362
 363          else
 364             if Is_Read_Only (Current_Attribute) then
 365                Error_Msg_Name_1 := Token_Name;
 366                Error_Msg
 367                  (Flags, "read-only attribute %% cannot be given a value",
 368                   Token_Ptr);
 369             end if;
 370
 371             if Attribute_Kind_Of (Current_Attribute) in
 372                  All_Case_Insensitive_Associative_Array
 373             then
 374                Set_Case_Insensitive (Attribute, In_Tree, To => True);
 375             end if;
 376          end if;
 377
 378          Scan (In_Tree); --  past the attribute name
 379
 380          --  Set the expression kind of the attribute
 381
 382          if Current_Attribute /= Empty_Attribute then
 383             Set_Expression_Kind_Of
 384               (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
 385             Optional_Index := Optional_Index_Of (Current_Attribute);
 386          end if;
 387       end Process_Attribute_Name;
 388
 389       -------------------------------------
 390       -- Process_Associative_Array_Index --
 391       -------------------------------------
 392
 393       procedure Process_Associative_Array_Index is
 394       begin
 395          --  If the attribute is not an associative array attribute, report
 396          --  an error. If this information is still unknown, set the kind
 397          --  to Associative_Array.
 398
 399          if Current_Attribute /= Empty_Attribute
 400            and then Attribute_Kind_Of (Current_Attribute) = Single
 401          then
 402             Error_Msg (Flags,
 403                        "the attribute """ &
 404                        Get_Name_String (Attribute_Name_Of (Current_Attribute))
 405                        & """ cannot be an associative array",
 406                        Location_Of (Attribute, In_Tree));
 407
 408          elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
 409             Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
 410          end if;
 411
 412          Scan (In_Tree); --  past the left parenthesis
 413
 414          if Others_Allowed_For (Current_Attribute)
 415            and then Token = Tok_Others
 416          then
 417             Set_Associative_Array_Index_Of
 418               (Attribute, In_Tree, All_Other_Names);
 419             Scan (In_Tree); --  past others
 420
 421          else
 422             if Others_Allowed_For (Current_Attribute) then
 423                Expect (Tok_String_Literal, "literal string or others");
 424             else
 425                Expect (Tok_String_Literal, "literal string");
 426             end if;
 427
 428             if Token = Tok_String_Literal then
 429                Get_Name_String (Token_Name);
 430
 431                if Case_Insensitive (Attribute, In_Tree) then
 432                   To_Lower (Name_Buffer (1 .. Name_Len));
 433                end if;
 434
 435                Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
 436                Scan (In_Tree); --  past the literal string index
 437
 438                if Token = Tok_At then
 439                   case Attribute_Kind_Of (Current_Attribute) is
 440                   when Optional_Index_Associative_Array |
 441                        Optional_Index_Case_Insensitive_Associative_Array =>
 442                      Scan (In_Tree);
 443                      Expect (Tok_Integer_Literal, "integer literal");
 444
 445                      if Token = Tok_Integer_Literal then
 446
 447                         --  Set the source index value from given literal
 448
 449                         declare
 450                            Index : constant Int :=
 451                                      UI_To_Int (Int_Literal_Value);
 452                         begin
 453                            if Index = 0 then
 454                               Error_Msg
 455                                 (Flags, "index cannot be zero", Token_Ptr);
 456                            else
 457                               Set_Source_Index_Of
 458                                 (Attribute, In_Tree, To => Index);
 459                            end if;
 460                         end;
 461
 462                         Scan (In_Tree);
 463                      end if;
 464
 465                   when others =>
 466                      Error_Msg (Flags, "index not allowed here", Token_Ptr);
 467                      Scan (In_Tree);
 468
 469                      if Token = Tok_Integer_Literal then
 470                         Scan (In_Tree);
 471                      end if;
 472                   end case;
 473                end if;
 474             end if;
 475          end if;
 476
 477          Expect (Tok_Right_Paren, "`)`");
 478
 479          if Token = Tok_Right_Paren then
 480             Scan (In_Tree); --  past the right parenthesis
 481          end if;
 482       end Process_Associative_Array_Index;
 483
 484    begin
 485       Attribute :=
 486         Default_Project_Node
 487           (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
 488       Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
 489       Set_Previous_Line_Node (Attribute);
 490
 491       --  Scan past "for"
 492
 493       Scan (In_Tree);
 494
 495       --  Body or External may be an attribute name
 496
 497       if Token = Tok_Body then
 498          Token := Tok_Identifier;
 499          Token_Name := Snames.Name_Body;
 500       end if;
 501
 502       if Token = Tok_External then
 503          Token := Tok_Identifier;
 504          Token_Name := Snames.Name_External;
 505       end if;
 506
 507       Expect (Tok_Identifier, "identifier");
 508       Process_Attribute_Name;
 509       Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
 510       Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
 511
 512       --  Associative array attributes
 513
 514       if Token = Tok_Left_Paren then
 515          Process_Associative_Array_Index;
 516
 517       else
 518          --  If it is an associative array attribute and there are no left
 519          --  parenthesis, then this is a full associative array declaration.
 520          --  Flag it as such for later processing of its value.
 521
 522          if Current_Attribute /= Empty_Attribute
 523            and then
 524              Attribute_Kind_Of (Current_Attribute) /= Single
 525          then
 526             if Attribute_Kind_Of (Current_Attribute) = Unknown then
 527                Set_Attribute_Kind_Of (Current_Attribute, To => Single);
 528
 529             else
 530                Full_Associative_Array := True;
 531             end if;
 532          end if;
 533       end if;
 534
 535       Expect (Tok_Use, "USE");
 536
 537       if Token = Tok_Use then
 538          Scan (In_Tree);
 539
 540          if Full_Associative_Array then
 541
 542             --  Expect <project>'<same_attribute_name>, or
 543             --  <project>.<same_package_name>'<same_attribute_name>
 544
 545             declare
 546                The_Project : Project_Node_Id := Empty_Node;
 547                --  The node of the project where the associative array is
 548                --  declared.
 549
 550                The_Package : Project_Node_Id := Empty_Node;
 551                --  The node of the package where the associative array is
 552                --  declared, if any.
 553
 554                Project_Name : Name_Id := No_Name;
 555                --  The name of the project where the associative array is
 556                --  declared.
 557
 558                Location : Source_Ptr := No_Location;
 559                --  The location of the project name
 560
 561             begin
 562                Expect (Tok_Identifier, "identifier");
 563
 564                if Token = Tok_Identifier then
 565                   Location := Token_Ptr;
 566
 567                   --  Find the project node in the imported project or
 568                   --  in the project being extended.
 569
 570                   The_Project := Imported_Or_Extended_Project_Of
 571                                    (Current_Project, In_Tree, Token_Name);
 572
 573                   if No (The_Project) then
 574                      Error_Msg (Flags, "unknown project", Location);
 575                      Scan (In_Tree); --  past the project name
 576
 577                   else
 578                      Project_Name := Token_Name;
 579                      Scan (In_Tree); --  past the project name
 580
 581                      --  If this is inside a package, a dot followed by the
 582                      --  name of the package must followed the project name.
 583
 584                      if Present (Current_Package) then
 585                         Expect (Tok_Dot, "`.`");
 586
 587                         if Token /= Tok_Dot then
 588                            The_Project := Empty_Node;
 589
 590                         else
 591                            Scan (In_Tree); --  past the dot
 592                            Expect (Tok_Identifier, "identifier");
 593
 594                            if Token /= Tok_Identifier then
 595                               The_Project := Empty_Node;
 596
 597                            --  If it is not the same package name, issue error
 598
 599                            elsif
 600                              Token_Name /= Name_Of (Current_Package, In_Tree)
 601                            then
 602                               The_Project := Empty_Node;
 603                               Error_Msg
 604                                 (Flags, "not the same package as " &
 605                                  Get_Name_String
 606                                    (Name_Of (Current_Package, In_Tree)),
 607                                  Token_Ptr);
 608
 609                            else
 610                               The_Package :=
 611                                 First_Package_Of (The_Project, In_Tree);
 612
 613                               --  Look for the package node
 614
 615                               while Present (The_Package)
 616                                 and then
 617                                 Name_Of (The_Package, In_Tree) /= Token_Name
 618                               loop
 619                                  The_Package :=
 620                                    Next_Package_In_Project
 621                                      (The_Package, In_Tree);
 622                               end loop;
 623
 624                               --  If the package cannot be found in the
 625                               --  project, issue an error.
 626
 627                               if No (The_Package) then
 628                                  The_Project := Empty_Node;
 629                                  Error_Msg_Name_2 := Project_Name;
 630                                  Error_Msg_Name_1 := Token_Name;
 631                                  Error_Msg
 632                                    (Flags,
 633                                     "package % not declared in project %",
 634                                     Token_Ptr);
 635                               end if;
 636
 637                               Scan (In_Tree); --  past the package name
 638                            end if;
 639                         end if;
 640                      end if;
 641                   end if;
 642                end if;
 643
 644                if Present (The_Project) then
 645
 646                   --  Looking for '<same attribute name>
 647
 648                   Expect (Tok_Apostrophe, "`''`");
 649
 650                   if Token /= Tok_Apostrophe then
 651                      The_Project := Empty_Node;
 652
 653                   else
 654                      Scan (In_Tree); --  past the apostrophe
 655                      Expect (Tok_Identifier, "identifier");
 656
 657                      if Token /= Tok_Identifier then
 658                         The_Project := Empty_Node;
 659
 660                      else
 661                         --  If it is not the same attribute name, issue error
 662
 663                         if Token_Name /= Attribute_Name then
 664                            The_Project := Empty_Node;
 665                            Error_Msg_Name_1 := Attribute_Name;
 666                            Error_Msg
 667                              (Flags, "invalid name, should be %", Token_Ptr);
 668                         end if;
 669
 670                         Scan (In_Tree); --  past the attribute name
 671                      end if;
 672                   end if;
 673                end if;
 674
 675                if No (The_Project) then
 676
 677                   --  If there were any problem, set the attribute id to null,
 678                   --  so that the node will not be recorded.
 679
 680                   Current_Attribute := Empty_Attribute;
 681
 682                else
 683                   --  Set the appropriate field in the node.
 684                   --  Note that the index and the expression are nil. This
 685                   --  characterizes full associative array attribute
 686                   --  declarations.
 687
 688                   Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
 689                   Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
 690                end if;
 691             end;
 692
 693          --  Other attribute declarations (not full associative array)
 694
 695          else
 696             declare
 697                Expression_Location : constant Source_Ptr := Token_Ptr;
 698                --  The location of the first token of the expression
 699
 700                Expression          : Project_Node_Id     := Empty_Node;
 701                --  The expression, value for the attribute declaration
 702
 703             begin
 704                --  Get the expression value and set it in the attribute node
 705
 706                Parse_Expression
 707                  (In_Tree         => In_Tree,
 708                   Expression      => Expression,
 709                   Flags           => Flags,
 710                   Current_Project => Current_Project,
 711                   Current_Package => Current_Package,
 712                   Optional_Index  => Optional_Index);
 713                Set_Expression_Of (Attribute, In_Tree, To => Expression);
 714
 715                --  If the expression is legal, but not of the right kind
 716                --  for the attribute, issue an error.
 717
 718                if Current_Attribute /= Empty_Attribute
 719                  and then Present (Expression)
 720                  and then Variable_Kind_Of (Current_Attribute) /=
 721                  Expression_Kind_Of (Expression, In_Tree)
 722                then
 723                   if  Variable_Kind_Of (Current_Attribute) = Undefined then
 724                      Set_Variable_Kind_Of
 725                        (Current_Attribute,
 726                         To => Expression_Kind_Of (Expression, In_Tree));
 727
 728                   else
 729                      Error_Msg
 730                        (Flags, "wrong expression kind for attribute """ &
 731                         Get_Name_String
 732                           (Attribute_Name_Of (Current_Attribute)) &
 733                         """",
 734                         Expression_Location);
 735                   end if;
 736                end if;
 737             end;
 738          end if;
 739       end if;
 740
 741       --  If the attribute was not recognized, return an empty node.
 742       --  It may be that it is not in a package to check, and the node will
 743       --  not be added to the tree.
 744
 745       if Current_Attribute = Empty_Attribute then
 746          Attribute := Empty_Node;
 747       end if;
 748
 749       Set_End_Of_Line (Attribute);
 750       Set_Previous_Line_Node (Attribute);
 751    end Parse_Attribute_Declaration;
 752
 753    -----------------------------
 754    -- Parse_Case_Construction --
 755    -----------------------------
 756
 757    procedure Parse_Case_Construction
 758      (In_Tree           : Project_Node_Tree_Ref;
 759       Case_Construction : out Project_Node_Id;
 760       First_Attribute   : Attribute_Node_Id;
 761       Current_Project   : Project_Node_Id;
 762       Current_Package   : Project_Node_Id;
 763       Packages_To_Check : String_List_Access;
 764       Is_Config_File    : Boolean;
 765       Flags             : Processing_Flags)
 766    is
 767       Current_Item    : Project_Node_Id := Empty_Node;
 768       Next_Item       : Project_Node_Id := Empty_Node;
 769       First_Case_Item : Boolean := True;
 770
 771       Variable_Location : Source_Ptr := No_Location;
 772
 773       String_Type : Project_Node_Id := Empty_Node;
 774
 775       Case_Variable : Project_Node_Id := Empty_Node;
 776
 777       First_Declarative_Item : Project_Node_Id := Empty_Node;
 778
 779       First_Choice           : Project_Node_Id := Empty_Node;
 780
 781       When_Others            : Boolean := False;
 782       --  Set to True when there is a "when others =>" clause
 783
 784    begin
 785       Case_Construction  :=
 786         Default_Project_Node
 787           (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
 788       Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
 789
 790       --  Scan past "case"
 791
 792       Scan (In_Tree);
 793
 794       --  Get the switch variable
 795
 796       Expect (Tok_Identifier, "identifier");
 797
 798       if Token = Tok_Identifier then
 799          Variable_Location := Token_Ptr;
 800          Parse_Variable_Reference
 801            (In_Tree         => In_Tree,
 802             Variable        => Case_Variable,
 803             Flags           => Flags,
 804             Current_Project => Current_Project,
 805             Current_Package => Current_Package);
 806          Set_Case_Variable_Reference_Of
 807            (Case_Construction, In_Tree, To => Case_Variable);
 808
 809       else
 810          if Token /= Tok_Is then
 811             Scan (In_Tree);
 812          end if;
 813       end if;
 814
 815       if Present (Case_Variable) then
 816          String_Type := String_Type_Of (Case_Variable, In_Tree);
 817
 818          if No (String_Type) then
 819             Error_Msg (Flags,
 820                        "variable """ &
 821                        Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
 822                        """ is not typed",
 823                        Variable_Location);
 824          end if;
 825       end if;
 826
 827       Expect (Tok_Is, "IS");
 828
 829       if Token = Tok_Is then
 830          Set_End_Of_Line (Case_Construction);
 831          Set_Previous_Line_Node (Case_Construction);
 832          Set_Next_End_Node (Case_Construction);
 833
 834          --  Scan past "is"
 835
 836          Scan (In_Tree);
 837       end if;
 838
 839       Start_New_Case_Construction (In_Tree, String_Type);
 840
 841       When_Loop :
 842
 843       while Token = Tok_When loop
 844
 845          if First_Case_Item then
 846             Current_Item :=
 847               Default_Project_Node
 848                 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
 849             Set_First_Case_Item_Of
 850               (Case_Construction, In_Tree, To => Current_Item);
 851             First_Case_Item := False;
 852
 853          else
 854             Next_Item :=
 855               Default_Project_Node
 856                 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
 857             Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
 858             Current_Item := Next_Item;
 859          end if;
 860
 861          Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
 862
 863          --  Scan past "when"
 864
 865          Scan (In_Tree);
 866
 867          if Token = Tok_Others then
 868             When_Others := True;
 869
 870             --  Scan past "others"
 871
 872             Scan (In_Tree);
 873
 874             Expect (Tok_Arrow, "`=>`");
 875             Set_End_Of_Line (Current_Item);
 876             Set_Previous_Line_Node (Current_Item);
 877
 878             --  Empty_Node in Field1 of a Case_Item indicates
 879             --  the "when others =>" branch.
 880
 881             Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
 882
 883             Parse_Declarative_Items
 884               (In_Tree           => In_Tree,
 885                Declarations      => First_Declarative_Item,
 886                In_Zone           => In_Case_Construction,
 887                First_Attribute   => First_Attribute,
 888                Current_Project   => Current_Project,
 889                Current_Package   => Current_Package,
 890                Packages_To_Check => Packages_To_Check,
 891                Is_Config_File    => Is_Config_File,
 892                Flags             => Flags);
 893
 894             --  "when others =>" must be the last branch, so save the
 895             --  Case_Item and exit
 896
 897             Set_First_Declarative_Item_Of
 898               (Current_Item, In_Tree, To => First_Declarative_Item);
 899             exit When_Loop;
 900
 901          else
 902             Parse_Choice_List
 903               (In_Tree      => In_Tree,
 904                First_Choice => First_Choice,
 905                Flags        => Flags);
 906             Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
 907
 908             Expect (Tok_Arrow, "`=>`");
 909             Set_End_Of_Line (Current_Item);
 910             Set_Previous_Line_Node (Current_Item);
 911
 912             Parse_Declarative_Items
 913               (In_Tree           => In_Tree,
 914                Declarations      => First_Declarative_Item,
 915                In_Zone           => In_Case_Construction,
 916                First_Attribute   => First_Attribute,
 917                Current_Project   => Current_Project,
 918                Current_Package   => Current_Package,
 919                Packages_To_Check => Packages_To_Check,
 920                Is_Config_File    => Is_Config_File,
 921                Flags             => Flags);
 922
 923             Set_First_Declarative_Item_Of
 924               (Current_Item, In_Tree, To => First_Declarative_Item);
 925
 926          end if;
 927       end loop When_Loop;
 928
 929       End_Case_Construction
 930         (Check_All_Labels => not When_Others and not Quiet_Output,
 931          Case_Location    => Location_Of (Case_Construction, In_Tree),
 932          Flags            => Flags);
 933
 934       Expect (Tok_End, "`END CASE`");
 935       Remove_Next_End_Node;
 936
 937       if Token = Tok_End then
 938
 939          --  Scan past "end"
 940
 941          Scan (In_Tree);
 942
 943          Expect (Tok_Case, "CASE");
 944
 945       end if;
 946
 947       --  Scan past "case"
 948
 949       Scan (In_Tree);
 950
 951       Expect (Tok_Semicolon, "`;`");
 952       Set_Previous_End_Node (Case_Construction);
 953
 954    end Parse_Case_Construction;
 955
 956    -----------------------------
 957    -- Parse_Declarative_Items --
 958    -----------------------------
 959
 960    procedure Parse_Declarative_Items
 961      (In_Tree           : Project_Node_Tree_Ref;
 962       Declarations      : out Project_Node_Id;
 963       In_Zone           : Zone;
 964       First_Attribute   : Attribute_Node_Id;
 965       Current_Project   : Project_Node_Id;
 966       Current_Package   : Project_Node_Id;
 967       Packages_To_Check : String_List_Access;
 968       Is_Config_File    : Boolean;
 969       Flags             : Processing_Flags)
 970    is
 971       Current_Declarative_Item : Project_Node_Id := Empty_Node;
 972       Next_Declarative_Item    : Project_Node_Id := Empty_Node;
 973       Current_Declaration      : Project_Node_Id := Empty_Node;
 974       Item_Location            : Source_Ptr      := No_Location;
 975
 976    begin
 977       Declarations := Empty_Node;
 978
 979       loop
 980          --  We are always positioned at the token that precedes the first
 981          --  token of the declarative element. Scan past it.
 982
 983          Scan (In_Tree);
 984
 985          Item_Location := Token_Ptr;
 986
 987          case Token is
 988             when Tok_Identifier =>
 989
 990                if In_Zone = In_Case_Construction then
 991
 992                   --  Check if the variable has already been declared
 993
 994                   declare
 995                      The_Variable : Project_Node_Id := Empty_Node;
 996
 997                   begin
 998                      if Present (Current_Package) then
 999                         The_Variable :=
1000                           First_Variable_Of (Current_Package, In_Tree);
1001                      elsif Present (Current_Project) then
1002                         The_Variable :=
1003                           First_Variable_Of (Current_Project, In_Tree);
1004                      end if;
1005
1006                      while Present (The_Variable)
1007                        and then Name_Of (The_Variable, In_Tree) /=
1008                                 Token_Name
1009                      loop
1010                         The_Variable := Next_Variable (The_Variable, In_Tree);
1011                      end loop;
1012
1013                      --  It is an error to declare a variable in a case
1014                      --  construction for the first time.
1015
1016                      if No (The_Variable) then
1017                         Error_Msg
1018                           (Flags,
1019                            "a variable cannot be declared " &
1020                            "for the first time here",
1021                            Token_Ptr);
1022                      end if;
1023                   end;
1024                end if;
1025
1026                Parse_Variable_Declaration
1027                  (In_Tree,
1028                   Current_Declaration,
1029                   Current_Project => Current_Project,
1030                   Current_Package => Current_Package,
1031                   Flags           => Flags);
1032
1033                Set_End_Of_Line (Current_Declaration);
1034                Set_Previous_Line_Node (Current_Declaration);
1035
1036             when Tok_For =>
1037
1038                Parse_Attribute_Declaration
1039                  (In_Tree           => In_Tree,
1040                   Attribute         => Current_Declaration,
1041                   First_Attribute   => First_Attribute,
1042                   Current_Project   => Current_Project,
1043                   Current_Package   => Current_Package,
1044                   Packages_To_Check => Packages_To_Check,
1045                   Flags             => Flags);
1046
1047                Set_End_Of_Line (Current_Declaration);
1048                Set_Previous_Line_Node (Current_Declaration);
1049
1050             when Tok_Null =>
1051
1052                Scan (In_Tree); --  past "null"
1053
1054             when Tok_Package =>
1055
1056                --  Package declaration
1057
1058                if In_Zone /= In_Project then
1059                   Error_Msg
1060                     (Flags, "a package cannot be declared here", Token_Ptr);
1061                end if;
1062
1063                Parse_Package_Declaration
1064                  (In_Tree             => In_Tree,
1065                   Package_Declaration => Current_Declaration,
1066                   Current_Project     => Current_Project,
1067                   Packages_To_Check   => Packages_To_Check,
1068                   Is_Config_File      => Is_Config_File,
1069                   Flags               => Flags);
1070
1071                Set_Previous_End_Node (Current_Declaration);
1072
1073             when Tok_Type =>
1074
1075                --  Type String Declaration
1076
1077                if In_Zone /= In_Project then
1078                   Error_Msg (Flags,
1079                              "a string type cannot be declared here",
1080                              Token_Ptr);
1081                end if;
1082
1083                Parse_String_Type_Declaration
1084                  (In_Tree         => In_Tree,
1085                   String_Type     => Current_Declaration,
1086                   Current_Project => Current_Project,
1087                   Flags           => Flags);
1088
1089                Set_End_Of_Line (Current_Declaration);
1090                Set_Previous_Line_Node (Current_Declaration);
1091
1092             when Tok_Case =>
1093
1094                --  Case construction
1095
1096                Parse_Case_Construction
1097                  (In_Tree           => In_Tree,
1098                   Case_Construction => Current_Declaration,
1099                   First_Attribute   => First_Attribute,
1100                   Current_Project   => Current_Project,
1101                   Current_Package   => Current_Package,
1102                   Packages_To_Check => Packages_To_Check,
1103                   Is_Config_File    => Is_Config_File,
1104                   Flags             => Flags);
1105
1106                Set_Previous_End_Node (Current_Declaration);
1107
1108             when others =>
1109                exit;
1110
1111                --  We are leaving Parse_Declarative_Items positioned
1112                --  at the first token after the list of declarative items.
1113                --  It could be "end" (for a project, a package declaration or
1114                --  a case construction) or "when" (for a case construction)
1115
1116          end case;
1117
1118          Expect (Tok_Semicolon, "`;` after declarative items");
1119
1120          --  Insert an N_Declarative_Item in the tree, but only if
1121          --  Current_Declaration is not an empty node.
1122
1123          if Present (Current_Declaration) then
1124             if No (Current_Declarative_Item) then
1125                Current_Declarative_Item :=
1126                  Default_Project_Node
1127                    (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1128                Declarations  := Current_Declarative_Item;
1129
1130             else
1131                Next_Declarative_Item :=
1132                  Default_Project_Node
1133                    (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1134                Set_Next_Declarative_Item
1135                  (Current_Declarative_Item, In_Tree,
1136                   To => Next_Declarative_Item);
1137                Current_Declarative_Item := Next_Declarative_Item;
1138             end if;
1139
1140             Set_Current_Item_Node
1141               (Current_Declarative_Item, In_Tree,
1142                To => Current_Declaration);
1143             Set_Location_Of
1144               (Current_Declarative_Item, In_Tree, To => Item_Location);
1145          end if;
1146       end loop;
1147    end Parse_Declarative_Items;
1148
1149    -------------------------------
1150    -- Parse_Package_Declaration --
1151    -------------------------------
1152
1153    procedure Parse_Package_Declaration
1154      (In_Tree             : Project_Node_Tree_Ref;
1155       Package_Declaration : out Project_Node_Id;
1156       Current_Project     : Project_Node_Id;
1157       Packages_To_Check   : String_List_Access;
1158       Is_Config_File      : Boolean;
1159       Flags               : Processing_Flags)
1160    is
1161       First_Attribute        : Attribute_Node_Id := Empty_Attribute;
1162       Current_Package        : Package_Node_Id   := Empty_Package;
1163       First_Declarative_Item : Project_Node_Id   := Empty_Node;
1164       Package_Location       : constant Source_Ptr := Token_Ptr;
1165       Renaming               : Boolean := False;
1166       Extending              : Boolean := False;
1167
1168    begin
1169       Package_Declaration :=
1170         Default_Project_Node
1171           (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
1172       Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
1173
1174       --  Scan past "package"
1175
1176       Scan (In_Tree);
1177       Expect (Tok_Identifier, "identifier");
1178
1179       if Token = Tok_Identifier then
1180          Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
1181
1182          Current_Package := Package_Node_Id_Of (Token_Name);
1183
1184          if Current_Package = Empty_Package then
1185             if not Quiet_Output then
1186                declare
1187                   List  : constant Strings.String_List := Package_Name_List;
1188                   Index : Natural;
1189                   Name  : constant String := Get_Name_String (Token_Name);
1190
1191                begin
1192                   --  Check for possible misspelling of a known package name
1193
1194                   Index := 0;
1195                   loop
1196                      if Index >= List'Last then
1197                         Index := 0;
1198                         exit;
1199                      end if;
1200
1201                      Index := Index + 1;
1202                      exit when
1203                        GNAT.Spelling_Checker.Is_Bad_Spelling_Of
1204                          (Name, List (Index).all);
1205                   end loop;
1206
1207                   --  Issue warning(s) in verbose mode or when a possible
1208                   --  misspelling has been found.
1209
1210                   if Verbose_Mode or else Index /= 0 then
1211                      Error_Msg (Flags,
1212                                 "?""" &
1213                                 Get_Name_String
1214                                  (Name_Of (Package_Declaration, In_Tree)) &
1215                                 """ is not a known package name",
1216                                 Token_Ptr);
1217                   end if;
1218
1219                   if Index /= 0 then
1220                      Error_Msg -- CODEFIX
1221                        (Flags,
1222                         "\?possible misspelling of """ &
1223                         List (Index).all & """", Token_Ptr);
1224                   end if;
1225                end;
1226             end if;
1227
1228             --  Set the package declaration to "ignored" so that it is not
1229             --  processed by Prj.Proc.Process.
1230
1231             Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1232
1233             --  Add the unknown package in the list of packages
1234
1235             Add_Unknown_Package (Token_Name, Current_Package);
1236
1237          elsif Current_Package = Unknown_Package then
1238
1239             --  Set the package declaration to "ignored" so that it is not
1240             --  processed by Prj.Proc.Process.
1241
1242             Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1243
1244          else
1245             First_Attribute := First_Attribute_Of (Current_Package);
1246          end if;
1247
1248          Set_Package_Id_Of
1249            (Package_Declaration, In_Tree, To => Current_Package);
1250
1251          declare
1252             Current : Project_Node_Id :=
1253                         First_Package_Of (Current_Project, In_Tree);
1254
1255          begin
1256             while Present (Current)
1257               and then Name_Of (Current, In_Tree) /= Token_Name
1258             loop
1259                Current := Next_Package_In_Project (Current, In_Tree);
1260             end loop;
1261
1262             if Present (Current) then
1263                Error_Msg
1264                  (Flags,
1265                   "package """ &
1266                   Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
1267                   """ is declared twice in the same project",
1268                   Token_Ptr);
1269
1270             else
1271                --  Add the package to the project list
1272
1273                Set_Next_Package_In_Project
1274                  (Package_Declaration, In_Tree,
1275                   To => First_Package_Of (Current_Project, In_Tree));
1276                Set_First_Package_Of
1277                  (Current_Project, In_Tree, To => Package_Declaration);
1278             end if;
1279          end;
1280
1281          --  Scan past the package name
1282
1283          Scan (In_Tree);
1284       end if;
1285
1286       Check_Package_Allowed
1287         (In_Tree, Current_Project, Package_Declaration, Flags);
1288
1289       if Token = Tok_Renames then
1290          Renaming := True;
1291       elsif Token = Tok_Extends then
1292          Extending := True;
1293       end if;
1294
1295       if Renaming or else Extending then
1296          if Is_Config_File then
1297             Error_Msg
1298               (Flags,
1299                "no package rename or extension in configuration projects",
1300                Token_Ptr);
1301          end if;
1302
1303          --  Scan past "renames" or "extends"
1304
1305          Scan (In_Tree);
1306
1307          Expect (Tok_Identifier, "identifier");
1308
1309          if Token = Tok_Identifier then
1310             declare
1311                Project_Name : constant Name_Id := Token_Name;
1312
1313                Clause       : Project_Node_Id :=
1314                               First_With_Clause_Of (Current_Project, In_Tree);
1315                The_Project  : Project_Node_Id := Empty_Node;
1316                Extended     : constant Project_Node_Id :=
1317                                 Extended_Project_Of
1318                                   (Project_Declaration_Of
1319                                     (Current_Project, In_Tree),
1320                                    In_Tree);
1321             begin
1322                while Present (Clause) loop
1323                   --  Only non limited imported projects may be used in a
1324                   --  renames declaration.
1325
1326                   The_Project :=
1327                     Non_Limited_Project_Node_Of (Clause, In_Tree);
1328                   exit when Present (The_Project)
1329                     and then Name_Of (The_Project, In_Tree) = Project_Name;
1330                   Clause := Next_With_Clause_Of (Clause, In_Tree);
1331                end loop;
1332
1333                if No (Clause) then
1334                   --  As we have not found the project in the imports, we check
1335                   --  if it's the name of an eventual extended project.
1336
1337                   if Present (Extended)
1338                     and then Name_Of (Extended, In_Tree) = Project_Name
1339                   then
1340                      Set_Project_Of_Renamed_Package_Of
1341                        (Package_Declaration, In_Tree, To => Extended);
1342                   else
1343                      Error_Msg_Name_1 := Project_Name;
1344                      Error_Msg
1345                        (Flags,
1346                         "% is not an imported or extended project", Token_Ptr);
1347                   end if;
1348                else
1349                   Set_Project_Of_Renamed_Package_Of
1350                     (Package_Declaration, In_Tree, To => The_Project);
1351                end if;
1352             end;
1353
1354             Scan (In_Tree);
1355             Expect (Tok_Dot, "`.`");
1356
1357             if Token = Tok_Dot then
1358                Scan (In_Tree);
1359                Expect (Tok_Identifier, "identifier");
1360
1361                if Token = Tok_Identifier then
1362                   if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1363                      Error_Msg (Flags, "not the same package name", Token_Ptr);
1364                   elsif
1365                     Present (Project_Of_Renamed_Package_Of
1366                                (Package_Declaration, In_Tree))
1367                   then
1368                      declare
1369                         Current : Project_Node_Id :=
1370                                     First_Package_Of
1371                                       (Project_Of_Renamed_Package_Of
1372                                            (Package_Declaration, In_Tree),
1373                                        In_Tree);
1374
1375                      begin
1376                         while Present (Current)
1377                           and then Name_Of (Current, In_Tree) /= Token_Name
1378                         loop
1379                            Current :=
1380                              Next_Package_In_Project (Current, In_Tree);
1381                         end loop;
1382
1383                         if No (Current) then
1384                            Error_Msg
1385                              (Flags, """" &
1386                               Get_Name_String (Token_Name) &
1387                               """ is not a package declared by the project",
1388                               Token_Ptr);
1389                         end if;
1390                      end;
1391                   end if;
1392
1393                   Scan (In_Tree);
1394                end if;
1395             end if;
1396          end if;
1397       end if;
1398
1399       if Renaming then
1400          Expect (Tok_Semicolon, "`;`");
1401          Set_End_Of_Line (Package_Declaration);
1402          Set_Previous_Line_Node (Package_Declaration);
1403
1404       elsif Token = Tok_Is then
1405          Set_End_Of_Line (Package_Declaration);
1406          Set_Previous_Line_Node (Package_Declaration);
1407          Set_Next_End_Node (Package_Declaration);
1408
1409          Parse_Declarative_Items
1410            (In_Tree           => In_Tree,
1411             Declarations      => First_Declarative_Item,
1412             In_Zone           => In_Package,
1413             First_Attribute   => First_Attribute,
1414             Current_Project   => Current_Project,
1415             Current_Package   => Package_Declaration,
1416             Packages_To_Check => Packages_To_Check,
1417             Is_Config_File    => Is_Config_File,
1418             Flags             => Flags);
1419
1420          Set_First_Declarative_Item_Of
1421            (Package_Declaration, In_Tree, To => First_Declarative_Item);
1422
1423          Expect (Tok_End, "END");
1424
1425          if Token = Tok_End then
1426
1427             --  Scan past "end"
1428
1429             Scan (In_Tree);
1430          end if;
1431
1432          --  We should have the name of the package after "end"
1433
1434          Expect (Tok_Identifier, "identifier");
1435
1436          if Token = Tok_Identifier
1437            and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1438            and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1439          then
1440             Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1441             Error_Msg (Flags, "expected %%", Token_Ptr);
1442          end if;
1443
1444          if Token /= Tok_Semicolon then
1445
1446             --  Scan past the package name
1447
1448             Scan (In_Tree);
1449          end if;
1450
1451          Expect (Tok_Semicolon, "`;`");
1452          Remove_Next_End_Node;
1453
1454       else
1455          Error_Msg (Flags, "expected IS", Token_Ptr);
1456       end if;
1457
1458    end Parse_Package_Declaration;
1459
1460    -----------------------------------
1461    -- Parse_String_Type_Declaration --
1462    -----------------------------------
1463
1464    procedure Parse_String_Type_Declaration
1465      (In_Tree         : Project_Node_Tree_Ref;
1466       String_Type     : out Project_Node_Id;
1467       Current_Project : Project_Node_Id;
1468       Flags           : Processing_Flags)
1469    is
1470       Current      : Project_Node_Id := Empty_Node;
1471       First_String : Project_Node_Id := Empty_Node;
1472
1473    begin
1474       String_Type :=
1475         Default_Project_Node
1476           (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1477
1478       Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1479
1480       --  Scan past "type"
1481
1482       Scan (In_Tree);
1483
1484       Expect (Tok_Identifier, "identifier");
1485
1486       if Token = Tok_Identifier then
1487          Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1488
1489          Current := First_String_Type_Of (Current_Project, In_Tree);
1490          while Present (Current)
1491            and then
1492            Name_Of (Current, In_Tree) /= Token_Name
1493          loop
1494             Current := Next_String_Type (Current, In_Tree);
1495          end loop;
1496
1497          if Present (Current) then
1498             Error_Msg (Flags,
1499                        "duplicate string type name """ &
1500                        Get_Name_String (Token_Name) &
1501                        """",
1502                        Token_Ptr);
1503          else
1504             Current := First_Variable_Of (Current_Project, In_Tree);
1505             while Present (Current)
1506               and then Name_Of (Current, In_Tree) /= Token_Name
1507             loop
1508                Current := Next_Variable (Current, In_Tree);
1509             end loop;
1510
1511             if Present (Current) then
1512                Error_Msg (Flags,
1513                           """" &
1514                           Get_Name_String (Token_Name) &
1515                           """ is already a variable name", Token_Ptr);
1516             else
1517                Set_Next_String_Type
1518                  (String_Type, In_Tree,
1519                   To => First_String_Type_Of (Current_Project, In_Tree));
1520                Set_First_String_Type_Of
1521                  (Current_Project, In_Tree, To => String_Type);
1522             end if;
1523          end if;
1524
1525          --  Scan past the name
1526
1527          Scan (In_Tree);
1528       end if;
1529
1530       Expect (Tok_Is, "IS");
1531
1532       if Token = Tok_Is then
1533          Scan (In_Tree);
1534       end if;
1535
1536       Expect (Tok_Left_Paren, "`(`");
1537
1538       if Token = Tok_Left_Paren then
1539          Scan (In_Tree);
1540       end if;
1541
1542       Parse_String_Type_List
1543         (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
1544       Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1545
1546       Expect (Tok_Right_Paren, "`)`");
1547
1548       if Token = Tok_Right_Paren then
1549          Scan (In_Tree);
1550       end if;
1551
1552    end Parse_String_Type_Declaration;
1553
1554    --------------------------------
1555    -- Parse_Variable_Declaration --
1556    --------------------------------
1557
1558    procedure Parse_Variable_Declaration
1559      (In_Tree         : Project_Node_Tree_Ref;
1560       Variable        : out Project_Node_Id;
1561       Current_Project : Project_Node_Id;
1562       Current_Package : Project_Node_Id;
1563       Flags           : Processing_Flags)
1564    is
1565       Expression_Location      : Source_Ptr;
1566       String_Type_Name         : Name_Id := No_Name;
1567       Project_String_Type_Name : Name_Id := No_Name;
1568       Type_Location            : Source_Ptr := No_Location;
1569       Project_Location         : Source_Ptr := No_Location;
1570       Expression               : Project_Node_Id := Empty_Node;
1571       Variable_Name            : constant Name_Id := Token_Name;
1572       OK                       : Boolean := True;
1573
1574    begin
1575       Variable :=
1576         Default_Project_Node
1577           (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1578       Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1579       Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1580
1581       --  Scan past the variable name
1582
1583       Scan (In_Tree);
1584
1585       if Token = Tok_Colon then
1586
1587          --  Typed string variable declaration
1588
1589          Scan (In_Tree);
1590          Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1591          Expect (Tok_Identifier, "identifier");
1592
1593          OK := Token = Tok_Identifier;
1594
1595          if OK then
1596             String_Type_Name := Token_Name;
1597             Type_Location := Token_Ptr;
1598             Scan (In_Tree);
1599
1600             if Token = Tok_Dot then
1601                Project_String_Type_Name := String_Type_Name;
1602                Project_Location := Type_Location;
1603
1604                --  Scan past the dot
1605
1606                Scan (In_Tree);
1607                Expect (Tok_Identifier, "identifier");
1608
1609                if Token = Tok_Identifier then
1610                   String_Type_Name := Token_Name;
1611                   Type_Location := Token_Ptr;
1612                   Scan (In_Tree);
1613                else
1614                   OK := False;
1615                end if;
1616             end if;
1617
1618             if OK then
1619                declare
1620                   Proj    : Project_Node_Id := Current_Project;
1621                   Current : Project_Node_Id := Empty_Node;
1622
1623                begin
1624                   if Project_String_Type_Name /= No_Name then
1625                      declare
1626                         The_Project_Name_And_Node : constant
1627                           Tree_Private_Part.Project_Name_And_Node :=
1628                           Tree_Private_Part.Projects_Htable.Get
1629                             (In_Tree.Projects_HT, Project_String_Type_Name);
1630
1631                         use Tree_Private_Part;
1632
1633                      begin
1634                         if The_Project_Name_And_Node =
1635                              Tree_Private_Part.No_Project_Name_And_Node
1636                         then
1637                            Error_Msg (Flags,
1638                                       "unknown project """ &
1639                                       Get_Name_String
1640                                          (Project_String_Type_Name) &
1641                                       """",
1642                                       Project_Location);
1643                            Current := Empty_Node;
1644                         else
1645                            Current :=
1646                              First_String_Type_Of
1647                                (The_Project_Name_And_Node.Node, In_Tree);
1648                            while
1649                              Present (Current)
1650                              and then
1651                                Name_Of (Current, In_Tree) /= String_Type_Name
1652                            loop
1653                               Current := Next_String_Type (Current, In_Tree);
1654                            end loop;
1655                         end if;
1656                      end;
1657
1658                   else
1659                      --  Look for a string type with the correct name in this
1660                      --  project or in any of its ancestors.
1661
1662                      loop
1663                         Current :=
1664                           First_String_Type_Of (Proj, In_Tree);
1665                         while
1666                           Present (Current)
1667                           and then
1668                             Name_Of (Current, In_Tree) /= String_Type_Name
1669                         loop
1670                            Current := Next_String_Type (Current, In_Tree);
1671                         end loop;
1672
1673                         exit when Present (Current);
1674
1675                         Proj := Parent_Project_Of (Proj, In_Tree);
1676                         exit when No (Proj);
1677                      end loop;
1678                   end if;
1679
1680                   if No (Current) then
1681                      Error_Msg (Flags,
1682                                 "unknown string type """ &
1683                                 Get_Name_String (String_Type_Name) &
1684                                 """",
1685                                 Type_Location);
1686                      OK := False;
1687
1688                   else
1689                      Set_String_Type_Of
1690                        (Variable, In_Tree, To => Current);
1691                   end if;
1692                end;
1693             end if;
1694          end if;
1695       end if;
1696
1697       Expect (Tok_Colon_Equal, "`:=`");
1698
1699       OK := OK and then Token = Tok_Colon_Equal;
1700
1701       if Token = Tok_Colon_Equal then
1702          Scan (In_Tree);
1703       end if;
1704
1705       --  Get the single string or string list value
1706
1707       Expression_Location := Token_Ptr;
1708
1709       Parse_Expression
1710         (In_Tree         => In_Tree,
1711          Expression      => Expression,
1712          Flags           => Flags,
1713          Current_Project => Current_Project,
1714          Current_Package => Current_Package,
1715          Optional_Index  => False);
1716       Set_Expression_Of (Variable, In_Tree, To => Expression);
1717
1718       if Present (Expression) then
1719          --  A typed string must have a single string value, not a list
1720
1721          if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1722            and then Expression_Kind_Of (Expression, In_Tree) = List
1723          then
1724             Error_Msg
1725               (Flags,
1726                "expression must be a single string", Expression_Location);
1727          end if;
1728
1729          Set_Expression_Kind_Of
1730            (Variable, In_Tree,
1731             To => Expression_Kind_Of (Expression, In_Tree));
1732       end if;
1733
1734       if OK then
1735          declare
1736             The_Variable : Project_Node_Id := Empty_Node;
1737
1738          begin
1739             if Present (Current_Package) then
1740                The_Variable := First_Variable_Of (Current_Package, In_Tree);
1741             elsif Present (Current_Project) then
1742                The_Variable := First_Variable_Of (Current_Project, In_Tree);
1743             end if;
1744
1745             while Present (The_Variable)
1746               and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1747             loop
1748                The_Variable := Next_Variable (The_Variable, In_Tree);
1749             end loop;
1750
1751             if No (The_Variable) then
1752                if Present (Current_Package) then
1753                   Set_Next_Variable
1754                     (Variable, In_Tree,
1755                      To => First_Variable_Of (Current_Package, In_Tree));
1756                   Set_First_Variable_Of
1757                     (Current_Package, In_Tree, To => Variable);
1758
1759                elsif Present (Current_Project) then
1760                   Set_Next_Variable
1761                     (Variable, In_Tree,
1762                      To => First_Variable_Of (Current_Project, In_Tree));
1763                   Set_First_Variable_Of
1764                     (Current_Project, In_Tree, To => Variable);
1765                end if;
1766
1767             else
1768                if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1769                   if Expression_Kind_Of (The_Variable, In_Tree) =
1770                                                             Undefined
1771                   then
1772                      Set_Expression_Kind_Of
1773                        (The_Variable, In_Tree,
1774                         To => Expression_Kind_Of (Variable, In_Tree));
1775
1776                   else
1777                      if Expression_Kind_Of (The_Variable, In_Tree) /=
1778                        Expression_Kind_Of (Variable, In_Tree)
1779                      then
1780                         Error_Msg (Flags,
1781                                    "wrong expression kind for variable """ &
1782                                    Get_Name_String
1783                                      (Name_Of (The_Variable, In_Tree)) &
1784                                      """",
1785                                    Expression_Location);
1786                      end if;
1787                   end if;
1788                end if;
1789             end if;
1790          end;
1791       end if;
1792    end Parse_Variable_Declaration;
1793
1794 end Prj.Dect;