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