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