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 --                                                                          --
  10 --           Copyright (C) 2001-2002 Free Software Foundation, Inc          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Errout;   use Errout;
  29 with Namet;    use Namet;
  30 with Prj.Strt; use Prj.Strt;
  31 with Prj.Tree; use Prj.Tree;
  32 with Scans;    use Scans;
  33 with Sinfo;    use Sinfo;
  34 with Types;    use Types;
  35 with Prj.Attr; use Prj.Attr;
  36
  37 package body Prj.Dect is
  38
  39    type Zone is (In_Project, In_Package, In_Case_Construction);
  40    --  Needs a comment ???
  41
  42    procedure Parse_Attribute_Declaration
  43      (Attribute         : out Project_Node_Id;
  44       First_Attribute   : Attribute_Node_Id;
  45       Current_Project   : Project_Node_Id;
  46       Current_Package   : Project_Node_Id);
  47    --  Parse an attribute declaration.
  48
  49    procedure Parse_Case_Construction
  50      (Case_Construction : out Project_Node_Id;
  51       First_Attribute   : Attribute_Node_Id;
  52       Current_Project   : Project_Node_Id;
  53       Current_Package   : Project_Node_Id);
  54    --  Parse a case construction
  55
  56    procedure Parse_Declarative_Items
  57      (Declarations      : out Project_Node_Id;
  58       In_Zone           : Zone;
  59       First_Attribute   : Attribute_Node_Id;
  60       Current_Project   : Project_Node_Id;
  61       Current_Package   : Project_Node_Id);
  62    --  Parse declarative items. Depending on In_Zone, some declarative
  63    --  items may be forbiden.
  64
  65    procedure Parse_Package_Declaration
  66      (Package_Declaration : out Project_Node_Id;
  67       Current_Project     : Project_Node_Id);
  68    --  Parse a package declaration
  69
  70    procedure Parse_String_Type_Declaration
  71      (String_Type     : out Project_Node_Id;
  72       Current_Project : Project_Node_Id);
  73    --  type <name> is ( <literal_string> { , <literal_string> } ) ;
  74
  75    procedure Parse_Variable_Declaration
  76      (Variable        : out Project_Node_Id;
  77       Current_Project : Project_Node_Id;
  78       Current_Package : Project_Node_Id);
  79    --  Parse a variable assignment
  80    --  <variable_Name> := <expression>; OR
  81    --  <variable_Name> : <string_type_Name> := <string_expression>;
  82
  83    -----------
  84    -- Parse --
  85    -----------
  86
  87    procedure Parse
  88      (Declarations    : out Project_Node_Id;
  89       Current_Project : Project_Node_Id;
  90       Extends         : Project_Node_Id)
  91    is
  92       First_Declarative_Item : Project_Node_Id := Empty_Node;
  93
  94    begin
  95       Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
  96       Set_Location_Of (Declarations, To => Token_Ptr);
  97       Set_Modified_Project_Of (Declarations, To => Extends);
  98       Set_Project_Declaration_Of (Current_Project, Declarations);
  99       Parse_Declarative_Items
 100         (Declarations    => First_Declarative_Item,
 101          In_Zone         => In_Project,
 102          First_Attribute => Prj.Attr.Attribute_First,
 103          Current_Project => Current_Project,
 104          Current_Package => Empty_Node);
 105       Set_First_Declarative_Item_Of
 106         (Declarations, To => First_Declarative_Item);
 107    end Parse;
 108
 109    ---------------------------------
 110    -- Parse_Attribute_Declaration --
 111    ---------------------------------
 112
 113    procedure Parse_Attribute_Declaration
 114      (Attribute       : out Project_Node_Id;
 115       First_Attribute : Attribute_Node_Id;
 116       Current_Project : Project_Node_Id;
 117       Current_Package : Project_Node_Id)
 118    is
 119       Current_Attribute : Attribute_Node_Id := First_Attribute;
 120
 121    begin
 122       Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
 123       Set_Location_Of (Attribute, To => Token_Ptr);
 124
 125       --  Scan past "for"
 126
 127       Scan;
 128
 129       Expect (Tok_Identifier, "identifier");
 130
 131       if Token = Tok_Identifier then
 132          Set_Name_Of (Attribute, To => Token_Name);
 133          Set_Location_Of (Attribute, To => Token_Ptr);
 134
 135          while Current_Attribute /= Empty_Attribute
 136            and then
 137              Attributes.Table (Current_Attribute).Name /= Token_Name
 138          loop
 139             Current_Attribute := Attributes.Table (Current_Attribute).Next;
 140          end loop;
 141
 142          if Current_Attribute = Empty_Attribute then
 143             Error_Msg ("undefined attribute """ &
 144                        Get_Name_String (Name_Of (Attribute)) &
 145                        """",
 146                        Token_Ptr);
 147
 148          elsif Attributes.Table (Current_Attribute).Kind_2 =
 149                             Case_Insensitive_Associative_Array
 150          then
 151             Set_Case_Insensitive (Attribute, To => True);
 152          end if;
 153
 154          Scan;
 155       end if;
 156
 157       if Token = Tok_Left_Paren then
 158          if Current_Attribute /= Empty_Attribute
 159            and then Attributes.Table (Current_Attribute).Kind_2 = Single
 160          then
 161             Error_Msg ("the attribute """ &
 162                        Get_Name_String
 163                           (Attributes.Table (Current_Attribute).Name) &
 164                        """ cannot be an associative array",
 165                        Location_Of (Attribute));
 166          end if;
 167
 168          Scan;
 169          Expect (Tok_String_Literal, "literal string");
 170
 171          if Token = Tok_String_Literal then
 172             Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
 173             Scan;
 174          end if;
 175
 176          Expect (Tok_Right_Paren, ")");
 177
 178          if Token = Tok_Right_Paren then
 179             Scan;
 180          end if;
 181
 182       else
 183          if Current_Attribute /= Empty_Attribute
 184            and then
 185              Attributes.Table (Current_Attribute).Kind_2 /= Single
 186          then
 187             Error_Msg ("the attribute """ &
 188                        Get_Name_String
 189                           (Attributes.Table (Current_Attribute).Name) &
 190                        """ needs to be an associative array",
 191                        Location_Of (Attribute));
 192          end if;
 193       end if;
 194
 195       if Current_Attribute /= Empty_Attribute then
 196          Set_Expression_Kind_Of
 197            (Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
 198       end if;
 199
 200       Expect (Tok_Use, "use");
 201
 202       if Token = Tok_Use then
 203          Scan;
 204
 205          declare
 206             Expression_Location : constant Source_Ptr := Token_Ptr;
 207             Expression          : Project_Node_Id     := Empty_Node;
 208
 209          begin
 210             Parse_Expression
 211               (Expression      => Expression,
 212                Current_Project => Current_Project,
 213                Current_Package => Current_Package);
 214             Set_Expression_Of (Attribute, To => Expression);
 215
 216             if Current_Attribute /= Empty_Attribute
 217               and then Expression /= Empty_Node
 218               and then Attributes.Table (Current_Attribute).Kind_1 /=
 219                                           Expression_Kind_Of (Expression)
 220             then
 221                Error_Msg
 222                  ("wrong expression kind for attribute """ &
 223                   Get_Name_String
 224                     (Attributes.Table (Current_Attribute).Name) &
 225                   """",
 226                   Expression_Location);
 227             end if;
 228          end;
 229       end if;
 230
 231    end Parse_Attribute_Declaration;
 232
 233    -----------------------------
 234    -- Parse_Case_Construction --
 235    -----------------------------
 236
 237    procedure Parse_Case_Construction
 238      (Case_Construction : out Project_Node_Id;
 239       First_Attribute   : Attribute_Node_Id;
 240       Current_Project   : Project_Node_Id;
 241       Current_Package   : Project_Node_Id)
 242    is
 243       Current_Item    : Project_Node_Id := Empty_Node;
 244       Next_Item       : Project_Node_Id := Empty_Node;
 245       First_Case_Item : Boolean := True;
 246
 247       Variable_Location : Source_Ptr := No_Location;
 248
 249       String_Type : Project_Node_Id := Empty_Node;
 250
 251       Case_Variable : Project_Node_Id := Empty_Node;
 252
 253       First_Declarative_Item : Project_Node_Id := Empty_Node;
 254
 255       First_Choice : Project_Node_Id := Empty_Node;
 256
 257    begin
 258       Case_Construction  :=
 259         Default_Project_Node (Of_Kind => N_Case_Construction);
 260       Set_Location_Of (Case_Construction, To => Token_Ptr);
 261
 262       --  Scan past "case"
 263
 264       Scan;
 265
 266       --  Get the switch variable
 267
 268       Expect (Tok_Identifier, "identifier");
 269
 270       if Token = Tok_Identifier then
 271          Variable_Location := Token_Ptr;
 272          Parse_Variable_Reference
 273            (Variable        => Case_Variable,
 274             Current_Project => Current_Project,
 275             Current_Package => Current_Package);
 276          Set_Case_Variable_Reference_Of
 277            (Case_Construction, To => Case_Variable);
 278
 279       else
 280          if Token /= Tok_Is then
 281             Scan;
 282          end if;
 283       end if;
 284
 285       if Case_Variable /= Empty_Node then
 286          String_Type := String_Type_Of (Case_Variable);
 287
 288          if String_Type = Empty_Node then
 289             Error_Msg ("variable """ &
 290                        Get_Name_String (Name_Of (Case_Variable)) &
 291                        """ is not typed",
 292                        Variable_Location);
 293          end if;
 294       end if;
 295
 296       Expect (Tok_Is, "is");
 297
 298       if Token = Tok_Is then
 299
 300          --  Scan past "is"
 301
 302          Scan;
 303       end if;
 304
 305       Start_New_Case_Construction (String_Type);
 306
 307       When_Loop :
 308
 309       while Token = Tok_When loop
 310
 311          if First_Case_Item then
 312             Current_Item := Default_Project_Node (Of_Kind => N_Case_Item);
 313             Set_First_Case_Item_Of (Case_Construction, To => Current_Item);
 314             First_Case_Item := False;
 315
 316          else
 317             Next_Item := Default_Project_Node (Of_Kind => N_Case_Item);
 318             Set_Next_Case_Item (Current_Item, To => Next_Item);
 319             Current_Item := Next_Item;
 320          end if;
 321
 322          Set_Location_Of (Current_Item, To => Token_Ptr);
 323
 324          --  Scan past "when"
 325
 326          Scan;
 327
 328          if Token = Tok_Others then
 329
 330             --  Scan past "others"
 331
 332             Scan;
 333
 334             Expect (Tok_Arrow, "=>");
 335
 336             --  Empty_Node in Field1 of a Case_Item indicates
 337             --  the "when others =>" branch.
 338
 339             Set_First_Choice_Of (Current_Item, To => Empty_Node);
 340
 341             Parse_Declarative_Items
 342               (Declarations    => First_Declarative_Item,
 343                In_Zone         => In_Case_Construction,
 344                First_Attribute => First_Attribute,
 345                Current_Project => Current_Project,
 346                Current_Package => Current_Package);
 347
 348             --  "when others =>" must be the last branch, so save the
 349             --  Case_Item and exit
 350
 351             Set_First_Declarative_Item_Of
 352               (Current_Item, To => First_Declarative_Item);
 353             exit When_Loop;
 354
 355          else
 356             Parse_Choice_List (First_Choice => First_Choice);
 357             Set_First_Choice_Of (Current_Item, To => First_Choice);
 358
 359             Expect (Tok_Arrow, "=>");
 360
 361             Parse_Declarative_Items
 362               (Declarations    => First_Declarative_Item,
 363                In_Zone         => In_Case_Construction,
 364                First_Attribute => First_Attribute,
 365                Current_Project => Current_Project,
 366                Current_Package => Current_Package);
 367
 368             Set_First_Declarative_Item_Of
 369               (Current_Item, To => First_Declarative_Item);
 370
 371          end if;
 372       end loop When_Loop;
 373
 374       End_Case_Construction;
 375
 376       Expect (Tok_End, "end case");
 377
 378       if Token = Tok_End then
 379
 380          --  Scan past "end"
 381
 382          Scan;
 383
 384          Expect (Tok_Case, "case");
 385
 386       end if;
 387
 388       --  Scan past "case"
 389
 390       Scan;
 391
 392       Expect (Tok_Semicolon, ";");
 393
 394    end Parse_Case_Construction;
 395
 396    -----------------------------
 397    -- Parse_Declarative_Items --
 398    -----------------------------
 399
 400    procedure Parse_Declarative_Items
 401      (Declarations    : out Project_Node_Id;
 402       In_Zone         : Zone;
 403       First_Attribute : Attribute_Node_Id;
 404       Current_Project : Project_Node_Id;
 405       Current_Package : Project_Node_Id)
 406    is
 407       Current_Declarative_Item : Project_Node_Id := Empty_Node;
 408       Next_Declarative_Item    : Project_Node_Id := Empty_Node;
 409       Current_Declaration      : Project_Node_Id := Empty_Node;
 410       Item_Location            : Source_Ptr      := No_Location;
 411
 412    begin
 413       Declarations := Empty_Node;
 414
 415       loop
 416          --  We are always positioned at the token that precedes
 417          --  the first token of the declarative element.
 418          --  Scan past it
 419
 420          Scan;
 421
 422          Item_Location := Token_Ptr;
 423
 424          case Token is
 425             when Tok_Identifier =>
 426
 427                if In_Zone = In_Case_Construction then
 428                   Error_Msg ("a variable cannot be declared here",
 429                              Token_Ptr);
 430                end if;
 431
 432                Parse_Variable_Declaration
 433                  (Current_Declaration,
 434                   Current_Project => Current_Project,
 435                   Current_Package => Current_Package);
 436
 437             when Tok_For =>
 438
 439                Parse_Attribute_Declaration
 440                  (Attribute       => Current_Declaration,
 441                   First_Attribute => First_Attribute,
 442                   Current_Project => Current_Project,
 443                   Current_Package => Current_Package);
 444
 445             when Tok_Package =>
 446
 447                --  Package declaration
 448
 449                if In_Zone /= In_Project then
 450                   Error_Msg ("a package cannot be declared here", Token_Ptr);
 451                end if;
 452
 453                Parse_Package_Declaration
 454                  (Package_Declaration => Current_Declaration,
 455                   Current_Project     => Current_Project);
 456
 457             when Tok_Type =>
 458
 459                --  Type String Declaration
 460
 461                if In_Zone /= In_Project then
 462                   Error_Msg ("a string type cannot be declared here",
 463                              Token_Ptr);
 464                end if;
 465
 466                Parse_String_Type_Declaration
 467                  (String_Type     => Current_Declaration,
 468                   Current_Project => Current_Project);
 469
 470             when Tok_Case =>
 471
 472                --  Case construction
 473
 474                Parse_Case_Construction
 475                  (Case_Construction => Current_Declaration,
 476                   First_Attribute   => First_Attribute,
 477                   Current_Project   => Current_Project,
 478                   Current_Package   => Current_Package);
 479
 480             when others =>
 481                exit;
 482
 483                --  We are leaving Parse_Declarative_Items positionned
 484                --  at the first token after the list of declarative items.
 485                --  It could be "end" (for a project, a package declaration or
 486                --  a case construction) or "when" (for a case construction)
 487
 488          end case;
 489
 490          Expect (Tok_Semicolon, "; after declarative items");
 491
 492          if Current_Declarative_Item = Empty_Node then
 493             Current_Declarative_Item :=
 494               Default_Project_Node (Of_Kind => N_Declarative_Item);
 495             Declarations  := Current_Declarative_Item;
 496
 497          else
 498             Next_Declarative_Item :=
 499               Default_Project_Node (Of_Kind => N_Declarative_Item);
 500             Set_Next_Declarative_Item
 501               (Current_Declarative_Item, To => Next_Declarative_Item);
 502             Current_Declarative_Item := Next_Declarative_Item;
 503          end if;
 504
 505          Set_Current_Item_Node
 506            (Current_Declarative_Item, To => Current_Declaration);
 507          Set_Location_Of (Current_Declarative_Item, To => Item_Location);
 508
 509       end loop;
 510
 511    end Parse_Declarative_Items;
 512
 513    -------------------------------
 514    -- Parse_Package_Declaration --
 515    -------------------------------
 516
 517    procedure Parse_Package_Declaration
 518      (Package_Declaration : out Project_Node_Id;
 519       Current_Project     : Project_Node_Id)
 520    is
 521       First_Attribute        : Attribute_Node_Id := Empty_Attribute;
 522       Current_Package        : Package_Node_Id   := Empty_Package;
 523       First_Declarative_Item : Project_Node_Id   := Empty_Node;
 524
 525    begin
 526       Package_Declaration :=
 527         Default_Project_Node (Of_Kind => N_Package_Declaration);
 528       Set_Location_Of (Package_Declaration, To => Token_Ptr);
 529
 530       --  Scan past "package"
 531
 532       Scan;
 533
 534       Expect (Tok_Identifier, "identifier");
 535
 536       if Token = Tok_Identifier then
 537
 538          Set_Name_Of (Package_Declaration, To => Token_Name);
 539
 540          for Index in Package_Attributes.First .. Package_Attributes.Last loop
 541             if Token_Name = Package_Attributes.Table (Index).Name then
 542                First_Attribute :=
 543                  Package_Attributes.Table (Index).First_Attribute;
 544                Current_Package := Index;
 545                exit;
 546             end if;
 547          end loop;
 548
 549          if Current_Package  = Empty_Package then
 550             Error_Msg ("""" &
 551                        Get_Name_String (Name_Of (Package_Declaration)) &
 552                        """ is not an allowed package name",
 553                        Token_Ptr);
 554
 555          else
 556             Set_Package_Id_Of (Package_Declaration, To => Current_Package);
 557
 558             declare
 559                Current : Project_Node_Id := First_Package_Of (Current_Project);
 560
 561             begin
 562                while Current /= Empty_Node
 563                  and then Name_Of (Current) /= Token_Name
 564                loop
 565                   Current := Next_Package_In_Project (Current);
 566                end loop;
 567
 568                if Current /= Empty_Node then
 569                   Error_Msg
 570                     ("package """ &
 571                      Get_Name_String (Name_Of (Package_Declaration)) &
 572                      """ is declared twice in the same project",
 573                      Token_Ptr);
 574
 575                else
 576                   --  Add the package to the project list
 577
 578                   Set_Next_Package_In_Project
 579                     (Package_Declaration,
 580                      To => First_Package_Of (Current_Project));
 581                   Set_First_Package_Of
 582                     (Current_Project, To => Package_Declaration);
 583                end if;
 584             end;
 585          end if;
 586
 587          --  Scan past the package name
 588
 589          Scan;
 590       end if;
 591
 592       if Token = Tok_Renames then
 593
 594          --  Scan past "renames"
 595
 596          Scan;
 597
 598          Expect (Tok_Identifier, "identifier");
 599
 600          if Token = Tok_Identifier then
 601             declare
 602                Project_Name : Name_Id := Token_Name;
 603                Clause       : Project_Node_Id :=
 604                                 First_With_Clause_Of (Current_Project);
 605                The_Project  : Project_Node_Id := Empty_Node;
 606
 607             begin
 608                while Clause /= Empty_Node loop
 609                   The_Project := Project_Node_Of (Clause);
 610                   exit when Name_Of (The_Project) = Project_Name;
 611                   Clause := Next_With_Clause_Of (Clause);
 612                end loop;
 613
 614                if Clause = Empty_Node then
 615                   Error_Msg ("""" &
 616                              Get_Name_String (Project_Name) &
 617                              """ is not an imported project", Token_Ptr);
 618                else
 619                   Set_Project_Of_Renamed_Package_Of
 620                     (Package_Declaration, To => The_Project);
 621                end if;
 622             end;
 623
 624             Scan;
 625             Expect (Tok_Dot, ".");
 626
 627             if Token = Tok_Dot then
 628                Scan;
 629                Expect (Tok_Identifier, "identifier");
 630
 631                if Token = Tok_Identifier then
 632                   if Name_Of (Package_Declaration) /= Token_Name then
 633                      Error_Msg ("not the same package name", Token_Ptr);
 634                   elsif
 635                     Project_Of_Renamed_Package_Of (Package_Declaration)
 636                                                               /= Empty_Node
 637                   then
 638                      declare
 639                         Current : Project_Node_Id :=
 640                                     First_Package_Of
 641                                       (Project_Of_Renamed_Package_Of
 642                                          (Package_Declaration));
 643
 644                      begin
 645                         while Current /= Empty_Node
 646                           and then Name_Of (Current) /= Token_Name
 647                         loop
 648                            Current := Next_Package_In_Project (Current);
 649                         end loop;
 650
 651                         if Current = Empty_Node then
 652                            Error_Msg
 653                              ("""" &
 654                               Get_Name_String (Token_Name) &
 655                               """ is not a package declared by the project",
 656                               Token_Ptr);
 657                         end if;
 658                      end;
 659                   end if;
 660
 661                   Scan;
 662                end if;
 663             end if;
 664          end if;
 665
 666          Expect (Tok_Semicolon, ";");
 667
 668       elsif Token = Tok_Is then
 669
 670          Parse_Declarative_Items
 671            (Declarations    => First_Declarative_Item,
 672             In_Zone         => In_Package,
 673             First_Attribute => First_Attribute,
 674             Current_Project => Current_Project,
 675             Current_Package => Package_Declaration);
 676
 677          Set_First_Declarative_Item_Of
 678            (Package_Declaration, To => First_Declarative_Item);
 679
 680          Expect (Tok_End, "end");
 681
 682          if Token = Tok_End then
 683
 684             --  Scan past "end"
 685
 686             Scan;
 687          end if;
 688
 689          --  We should have the name of the package after "end"
 690
 691          Expect (Tok_Identifier, "identifier");
 692
 693          if Token = Tok_Identifier
 694            and then Name_Of (Package_Declaration) /= No_Name
 695            and then Token_Name /= Name_Of (Package_Declaration)
 696          then
 697             Error_Msg_Name_1 := Name_Of (Package_Declaration);
 698             Error_Msg ("expected {", Token_Ptr);
 699          end if;
 700
 701          if Token /= Tok_Semicolon then
 702
 703             --  Scan past the package name
 704
 705             Scan;
 706          end if;
 707
 708          Expect (Tok_Semicolon, ";");
 709
 710       else
 711          Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
 712       end if;
 713
 714    end Parse_Package_Declaration;
 715
 716    -----------------------------------
 717    -- Parse_String_Type_Declaration --
 718    -----------------------------------
 719
 720    procedure Parse_String_Type_Declaration
 721      (String_Type     : out Project_Node_Id;
 722       Current_Project : Project_Node_Id)
 723    is
 724       Current      : Project_Node_Id := Empty_Node;
 725       First_String : Project_Node_Id := Empty_Node;
 726
 727    begin
 728       String_Type :=
 729         Default_Project_Node (Of_Kind => N_String_Type_Declaration);
 730
 731       Set_Location_Of (String_Type, To => Token_Ptr);
 732
 733       --  Scan past "type"
 734
 735       Scan;
 736
 737       Expect (Tok_Identifier, "identifier");
 738
 739       if Token = Tok_Identifier then
 740          Set_Name_Of (String_Type, To => Token_Name);
 741
 742          Current := First_String_Type_Of (Current_Project);
 743          while Current /= Empty_Node
 744            and then
 745            Name_Of (Current) /= Token_Name
 746          loop
 747             Current := Next_String_Type (Current);
 748          end loop;
 749
 750          if Current /= Empty_Node then
 751             Error_Msg ("duplicate string type name """ &
 752                        Get_Name_String (Token_Name) &
 753                        """",
 754                        Token_Ptr);
 755          else
 756             Current := First_Variable_Of (Current_Project);
 757             while Current /= Empty_Node
 758               and then Name_Of (Current) /= Token_Name
 759             loop
 760                Current := Next_Variable (Current);
 761             end loop;
 762
 763             if Current /= Empty_Node then
 764                Error_Msg ("""" &
 765                           Get_Name_String (Token_Name) &
 766                           """ is already a variable name", Token_Ptr);
 767             else
 768                Set_Next_String_Type
 769                  (String_Type, To => First_String_Type_Of (Current_Project));
 770                Set_First_String_Type_Of (Current_Project, To => String_Type);
 771             end if;
 772          end if;
 773
 774          --  Scan past the name
 775
 776          Scan;
 777       end if;
 778
 779       Expect (Tok_Is, "is");
 780
 781       if Token = Tok_Is then
 782          Scan;
 783       end if;
 784
 785       Expect (Tok_Left_Paren, "(");
 786
 787       if Token = Tok_Left_Paren then
 788          Scan;
 789       end if;
 790
 791       Parse_String_Type_List (First_String => First_String);
 792       Set_First_Literal_String (String_Type, To => First_String);
 793
 794       Expect (Tok_Right_Paren, ")");
 795
 796       if Token = Tok_Right_Paren then
 797          Scan;
 798       end if;
 799
 800    end Parse_String_Type_Declaration;
 801
 802    --------------------------------
 803    -- Parse_Variable_Declaration --
 804    --------------------------------
 805
 806    procedure Parse_Variable_Declaration
 807      (Variable        : out Project_Node_Id;
 808       Current_Project : Project_Node_Id;
 809       Current_Package : Project_Node_Id)
 810    is
 811       Expression_Location      : Source_Ptr;
 812       String_Type_Name         : Name_Id := No_Name;
 813       Project_String_Type_Name : Name_Id := No_Name;
 814       Type_Location            : Source_Ptr := No_Location;
 815       Project_Location         : Source_Ptr := No_Location;
 816       Expression               : Project_Node_Id := Empty_Node;
 817       Variable_Name            : constant Name_Id := Token_Name;
 818
 819    begin
 820       Variable :=
 821         Default_Project_Node (Of_Kind => N_Variable_Declaration);
 822       Set_Name_Of (Variable, To => Variable_Name);
 823       Set_Location_Of (Variable, To => Token_Ptr);
 824
 825       --  Scan past the variable name
 826
 827       Scan;
 828
 829       if Token = Tok_Colon then
 830
 831          --  Typed string variable declaration
 832
 833          Scan;
 834          Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
 835          Expect (Tok_Identifier, "identifier");
 836
 837          if Token = Tok_Identifier then
 838             String_Type_Name := Token_Name;
 839             Type_Location := Token_Ptr;
 840             Scan;
 841
 842             if Token = Tok_Dot then
 843                Project_String_Type_Name := String_Type_Name;
 844                Project_Location := Type_Location;
 845
 846                --  Scan past the dot
 847
 848                Scan;
 849                Expect (Tok_Identifier, "identifier");
 850
 851                if Token = Tok_Identifier then
 852                   String_Type_Name := Token_Name;
 853                   Type_Location := Token_Ptr;
 854                   Scan;
 855                else
 856                   String_Type_Name := No_Name;
 857                end if;
 858             end if;
 859
 860             if String_Type_Name /= No_Name then
 861                declare
 862                   Current : Project_Node_Id :=
 863                               First_String_Type_Of (Current_Project);
 864
 865                begin
 866                   if Project_String_Type_Name /= No_Name then
 867                      declare
 868                         The_Project_Name_And_Node : constant
 869                           Tree_Private_Part.Project_Name_And_Node :=
 870                           Tree_Private_Part.Projects_Htable.Get
 871                                                     (Project_String_Type_Name);
 872
 873                         use Tree_Private_Part;
 874
 875                      begin
 876                         if The_Project_Name_And_Node =
 877                           Tree_Private_Part.No_Project_Name_And_Node
 878                         then
 879                            Error_Msg ("unknown project """ &
 880                                       Get_Name_String
 881                                          (Project_String_Type_Name) &
 882                                       """",
 883                                       Project_Location);
 884                            Current := Empty_Node;
 885                         else
 886                            Current :=
 887                              First_String_Type_Of
 888                                          (The_Project_Name_And_Node.Node);
 889                         end if;
 890                      end;
 891                   end if;
 892
 893                   while Current /= Empty_Node
 894                     and then Name_Of (Current) /= String_Type_Name
 895                   loop
 896                      Current := Next_String_Type (Current);
 897                   end loop;
 898
 899                   if Current = Empty_Node then
 900                      Error_Msg ("unknown string type """ &
 901                                 Get_Name_String (String_Type_Name) &
 902                                 """",
 903                                 Type_Location);
 904                   else
 905                      Set_String_Type_Of
 906                        (Variable, To => Current);
 907                   end if;
 908                end;
 909             end if;
 910          end if;
 911       end if;
 912
 913       Expect (Tok_Colon_Equal, ":=");
 914
 915       if Token = Tok_Colon_Equal then
 916          Scan;
 917       end if;
 918
 919       --  Get the single string or string list value
 920
 921       Expression_Location := Token_Ptr;
 922
 923       Parse_Expression
 924         (Expression      => Expression,
 925          Current_Project => Current_Project,
 926          Current_Package => Current_Package);
 927       Set_Expression_Of (Variable, To => Expression);
 928
 929       if Expression /= Empty_Node then
 930          Set_Expression_Kind_Of
 931            (Variable, To => Expression_Kind_Of (Expression));
 932       end if;
 933
 934       declare
 935          The_Variable : Project_Node_Id := Empty_Node;
 936
 937       begin
 938          if Current_Package /= Empty_Node then
 939             The_Variable :=  First_Variable_Of (Current_Package);
 940          elsif Current_Project /= Empty_Node then
 941             The_Variable :=  First_Variable_Of (Current_Project);
 942          end if;
 943
 944          while The_Variable /= Empty_Node
 945            and then Name_Of (The_Variable) /= Variable_Name
 946          loop
 947             The_Variable := Next_Variable (The_Variable);
 948          end loop;
 949
 950          if The_Variable = Empty_Node then
 951             if Current_Package /= Empty_Node then
 952                Set_Next_Variable
 953                  (Variable, To => First_Variable_Of (Current_Package));
 954                Set_First_Variable_Of (Current_Package, To => Variable);
 955
 956             elsif Current_Project /= Empty_Node then
 957                Set_Next_Variable
 958                  (Variable, To => First_Variable_Of (Current_Project));
 959                Set_First_Variable_Of (Current_Project, To => Variable);
 960             end if;
 961
 962          else
 963             if Expression_Kind_Of (Variable) /= Undefined then
 964                if Expression_Kind_Of (The_Variable) = Undefined then
 965                   Set_Expression_Kind_Of
 966                     (The_Variable, To => Expression_Kind_Of (Variable));
 967
 968                else
 969                   if Expression_Kind_Of (The_Variable) /=
 970                                                  Expression_Kind_Of (Variable)
 971                   then
 972                      Error_Msg ("wrong expression kind for variable """ &
 973                                 Get_Name_String (Name_Of (The_Variable)) &
 974                                 """",
 975                                 Expression_Location);
 976                   end if;
 977                end if;
 978             end if;
 979          end if;
 980       end;
 981
 982    end Parse_Variable_Declaration;
 983
 984 end Prj.Dect;