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