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