gcc/ada/prj-strt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P R J . S T R 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 Prj.Attr;  use Prj.Attr;
  30 with Prj.Err;   use Prj.Err;
  31 with Prj.Tree;  use Prj.Tree;
  32 with Scans;     use Scans;
  33 with Snames;
  34 with Table;
  35 with Types;     use Types;
  36 with Uintp;     use Uintp;
  37
  38 package body Prj.Strt is
  39
  40    type Choice_String is record
  41       The_String   : Name_Id;
  42       Already_Used : Boolean := False;
  43    end record;
  44    --  The string of a case label, and an indication that it has already
  45    --  been used (to avoid duplicate case labels).
  46
  47    Choices_Initial   : constant := 10;
  48    Choices_Increment : constant := 50;
  49
  50    Choice_Node_Low_Bound  : constant := 0;
  51    Choice_Node_High_Bound : constant := 099_999_999;
  52    --  In practice, infinite
  53
  54    type Choice_Node_Id is
  55      range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
  56
  57    First_Choice_Node_Id : constant Choice_Node_Id :=
  58      Choice_Node_Low_Bound;
  59
  60    package Choices is
  61       new Table.Table (Table_Component_Type => Choice_String,
  62                        Table_Index_Type     => Choice_Node_Id,
  63                        Table_Low_Bound      => First_Choice_Node_Id,
  64                        Table_Initial        => Choices_Initial,
  65                        Table_Increment      => Choices_Increment,
  66                        Table_Name           => "Prj.Strt.Choices");
  67    --  Used to store the case labels and check that there is no duplicate.
  68
  69    package Choice_Lasts is
  70       new Table.Table (Table_Component_Type => Choice_Node_Id,
  71                        Table_Index_Type     => Nat,
  72                        Table_Low_Bound      => 1,
  73                        Table_Initial        => 10,
  74                        Table_Increment      => 100,
  75                        Table_Name           => "Prj.Strt.Choice_Lasts");
  76    --  Used to store the indices of the choices in table Choices,
  77    --  to distinguish nested case constructions.
  78
  79    Choice_First : Choice_Node_Id := 0;
  80    --  Index in table Choices of the first case label of the current
  81    --  case construction. Zero means no current case construction.
  82
  83    type Name_Location is record
  84       Name     : Name_Id := No_Name;
  85       Location : Source_Ptr := No_Location;
  86    end record;
  87    --  Store the identifier and the location of a simple name
  88
  89    package Names is
  90       new Table.Table (Table_Component_Type => Name_Location,
  91                        Table_Index_Type     => Nat,
  92                        Table_Low_Bound      => 1,
  93                        Table_Initial        => 10,
  94                        Table_Increment      => 100,
  95                        Table_Name           => "Prj.Strt.Names");
  96    --  Used to accumulate the single names of a name
  97
  98    procedure Add (This_String : Name_Id);
  99    --  Add a string to the case label list, indicating that it has not
 100    --  yet been used.
 101
 102    procedure Add_To_Names (NL : Name_Location);
 103    --  Add one single names to table Names
 104
 105    procedure External_Reference (External_Value : out Project_Node_Id);
 106    --  Parse an external reference. Current token is "external".
 107
 108    procedure Attribute_Reference
 109      (Reference       : out Project_Node_Id;
 110       First_Attribute : Attribute_Node_Id;
 111       Current_Project : Project_Node_Id;
 112       Current_Package : Project_Node_Id);
 113    --  Parse an attribute reference. Current token is an apostrophe.
 114
 115    procedure Terms
 116      (Term            : out Project_Node_Id;
 117       Expr_Kind       : in out Variable_Kind;
 118       Current_Project : Project_Node_Id;
 119       Current_Package : Project_Node_Id;
 120       Optional_Index  : Boolean);
 121    --  Recursive procedure to parse one term or several terms concatenated
 122    --  using "&".
 123
 124    ---------
 125    -- Add --
 126    ---------
 127
 128    procedure Add (This_String : Name_Id) is
 129    begin
 130       Choices.Increment_Last;
 131       Choices.Table (Choices.Last) :=
 132         (The_String   => This_String,
 133          Already_Used => False);
 134    end Add;
 135
 136    ------------------
 137    -- Add_To_Names --
 138    ------------------
 139
 140    procedure Add_To_Names (NL : Name_Location) is
 141    begin
 142       Names.Increment_Last;
 143       Names.Table (Names.Last) := NL;
 144    end Add_To_Names;
 145
 146    -------------------------
 147    -- Attribute_Reference --
 148    -------------------------
 149
 150    procedure Attribute_Reference
 151      (Reference       : out Project_Node_Id;
 152       First_Attribute : Attribute_Node_Id;
 153       Current_Project : Project_Node_Id;
 154       Current_Package : Project_Node_Id)
 155    is
 156       Current_Attribute : Attribute_Node_Id := First_Attribute;
 157
 158    begin
 159       --  Declare the node of the attribute reference
 160
 161       Reference :=  Default_Project_Node (Of_Kind => N_Attribute_Reference);
 162       Set_Location_Of (Reference, To => Token_Ptr);
 163       Scan; --  past apostrophe
 164
 165       --  Body may be an attribute name
 166
 167       if Token = Tok_Body then
 168          Token      := Tok_Identifier;
 169          Token_Name := Snames.Name_Body;
 170       end if;
 171
 172       Expect (Tok_Identifier, "identifier");
 173
 174       if Token = Tok_Identifier then
 175          Set_Name_Of (Reference, To => Token_Name);
 176
 177          --  Check if the identifier is one of the attribute identifiers in the
 178          --  context (package or project level attributes).
 179
 180          Current_Attribute :=
 181            Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute);
 182
 183          --  If the identifier is not allowed, report an error
 184
 185          if Current_Attribute = Empty_Attribute then
 186             Error_Msg_Name_1 := Token_Name;
 187             Error_Msg ("unknown attribute %", Token_Ptr);
 188             Reference := Empty_Node;
 189
 190             --  Scan past the attribute name
 191
 192             Scan;
 193
 194          else
 195             --  Give its characteristics to this attribute reference
 196
 197             Set_Project_Node_Of (Reference, To => Current_Project);
 198             Set_Package_Node_Of (Reference, To => Current_Package);
 199             Set_Expression_Kind_Of
 200               (Reference, To => Variable_Kind_Of (Current_Attribute));
 201             Set_Case_Insensitive
 202               (Reference, To => Attribute_Kind_Of (Current_Attribute) =
 203                                           Case_Insensitive_Associative_Array);
 204
 205             --  Scan past the attribute name
 206
 207             Scan;
 208
 209             --  If the attribute is an associative array, get the index
 210
 211             if Attribute_Kind_Of (Current_Attribute) /= Single then
 212                Expect (Tok_Left_Paren, "`(`");
 213
 214                if Token = Tok_Left_Paren then
 215                   Scan;
 216                   Expect (Tok_String_Literal, "literal string");
 217
 218                   if Token = Tok_String_Literal then
 219                      Set_Associative_Array_Index_Of
 220                        (Reference, To => Token_Name);
 221                      Scan;
 222                      Expect (Tok_Right_Paren, "`)`");
 223
 224                      if Token = Tok_Right_Paren then
 225                         Scan;
 226                      end if;
 227                   end if;
 228                end if;
 229             end if;
 230          end if;
 231
 232          --  Change name of obsolete attributes
 233
 234          if Reference /= Empty_Node then
 235             case Name_Of (Reference) is
 236                when Snames.Name_Specification =>
 237                   Set_Name_Of (Reference, To => Snames.Name_Spec);
 238
 239                when Snames.Name_Specification_Suffix =>
 240                   Set_Name_Of (Reference, To => Snames.Name_Spec_Suffix);
 241
 242                when Snames.Name_Implementation =>
 243                   Set_Name_Of (Reference, To => Snames.Name_Body);
 244
 245                when Snames.Name_Implementation_Suffix =>
 246                   Set_Name_Of (Reference, To => Snames.Name_Body_Suffix);
 247
 248                when others =>
 249                   null;
 250             end case;
 251          end if;
 252       end if;
 253    end Attribute_Reference;
 254
 255    ---------------------------
 256    -- End_Case_Construction --
 257    ---------------------------
 258
 259    procedure End_Case_Construction
 260      (Check_All_Labels   : Boolean;
 261       Case_Location      : Source_Ptr)
 262    is
 263       Non_Used : Natural := 0;
 264       First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
 265    begin
 266       --  First, if Check_All_Labels is True, check if all values
 267       --  of the string type have been used.
 268
 269       if Check_All_Labels then
 270          for Choice in Choice_First .. Choices.Last loop
 271                if not Choices.Table (Choice).Already_Used then
 272                   Non_Used := Non_Used + 1;
 273
 274                   if Non_Used = 1 then
 275                      First_Non_Used := Choice;
 276                   end if;
 277                end if;
 278          end loop;
 279
 280          --  If only one is not used, report a single warning for this value
 281
 282          if Non_Used = 1 then
 283             Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
 284             Error_Msg ("?value { is not used as label", Case_Location);
 285
 286          --  If several are not used, report a warning for each one of them
 287
 288          elsif Non_Used > 1 then
 289             Error_Msg
 290               ("?the following values are not used as labels:",
 291                Case_Location);
 292
 293             for Choice in First_Non_Used .. Choices.Last loop
 294                if not Choices.Table (Choice).Already_Used then
 295                   Error_Msg_Name_1 := Choices.Table (Choice).The_String;
 296                   Error_Msg ("\?{", Case_Location);
 297                end if;
 298             end loop;
 299          end if;
 300       end if;
 301
 302       --  If this is the only case construction, empty the tables
 303
 304       if Choice_Lasts.Last = 1 then
 305          Choice_Lasts.Set_Last (0);
 306          Choices.Set_Last (First_Choice_Node_Id);
 307          Choice_First := 0;
 308
 309       elsif Choice_Lasts.Last = 2 then
 310          --  This is the second case onstruction, set the tables to the first
 311
 312          Choice_Lasts.Set_Last (1);
 313          Choices.Set_Last (Choice_Lasts.Table (1));
 314          Choice_First := 1;
 315
 316       else
 317          --  This is the 3rd or more case construction, set the tables to the
 318          --  previous one.
 319
 320          Choice_Lasts.Decrement_Last;
 321          Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
 322          Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
 323       end if;
 324    end End_Case_Construction;
 325
 326    ------------------------
 327    -- External_Reference --
 328    ------------------------
 329
 330    procedure External_Reference (External_Value : out Project_Node_Id) is
 331       Field_Id : Project_Node_Id := Empty_Node;
 332
 333    begin
 334       External_Value :=
 335         Default_Project_Node (Of_Kind       => N_External_Value,
 336                               And_Expr_Kind => Single);
 337       Set_Location_Of (External_Value, To => Token_Ptr);
 338
 339       --  The current token is External
 340
 341       --  Get the left parenthesis
 342
 343       Scan;
 344       Expect (Tok_Left_Paren, "`(`");
 345
 346       --  Scan past the left parenthesis
 347
 348       if Token = Tok_Left_Paren then
 349          Scan;
 350       end if;
 351
 352       --  Get the name of the external reference
 353
 354       Expect (Tok_String_Literal, "literal string");
 355
 356       if Token = Tok_String_Literal then
 357          Field_Id :=
 358            Default_Project_Node (Of_Kind       => N_Literal_String,
 359                                  And_Expr_Kind => Single);
 360          Set_String_Value_Of (Field_Id, To => Token_Name);
 361          Set_External_Reference_Of (External_Value, To => Field_Id);
 362
 363          --  Scan past the first argument
 364
 365          Scan;
 366
 367          case Token is
 368
 369             when Tok_Right_Paren =>
 370
 371                --  Scan past the right parenthesis
 372                Scan;
 373
 374             when Tok_Comma =>
 375
 376                --  Scan past the comma
 377
 378                Scan;
 379
 380                Expect (Tok_String_Literal, "literal string");
 381
 382                --  Get the default
 383
 384                if Token = Tok_String_Literal then
 385                   Field_Id :=
 386                     Default_Project_Node (Of_Kind       => N_Literal_String,
 387                                           And_Expr_Kind => Single);
 388                   Set_String_Value_Of (Field_Id, To => Token_Name);
 389                   Set_External_Default_Of (External_Value, To => Field_Id);
 390                   Scan;
 391                   Expect (Tok_Right_Paren, "`)`");
 392                end if;
 393
 394                --  Scan past the right parenthesis
 395                if Token = Tok_Right_Paren then
 396                   Scan;
 397                end if;
 398
 399             when others =>
 400                Error_Msg ("`,` or `)` expected", Token_Ptr);
 401          end case;
 402       end if;
 403    end External_Reference;
 404
 405    -----------------------
 406    -- Parse_Choice_List --
 407    -----------------------
 408
 409    procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is
 410       Current_Choice : Project_Node_Id := Empty_Node;
 411       Next_Choice    : Project_Node_Id := Empty_Node;
 412       Choice_String  : Name_Id         := No_Name;
 413       Found          : Boolean         := False;
 414
 415    begin
 416       --  Declare the node of the first choice
 417
 418       First_Choice :=
 419         Default_Project_Node (Of_Kind       => N_Literal_String,
 420                               And_Expr_Kind => Single);
 421
 422       --  Initially Current_Choice is the same as First_Choice
 423
 424       Current_Choice := First_Choice;
 425
 426       loop
 427          Expect (Tok_String_Literal, "literal string");
 428          exit when Token /= Tok_String_Literal;
 429          Set_Location_Of (Current_Choice, To => Token_Ptr);
 430          Choice_String := Token_Name;
 431
 432          --  Give the string value to the current choice
 433
 434          Set_String_Value_Of (Current_Choice, To => Choice_String);
 435
 436          --  Check if the label is part of the string type and if it has not
 437          --  been already used.
 438
 439          Found := False;
 440          for Choice in Choice_First .. Choices.Last loop
 441             if Choices.Table (Choice).The_String = Choice_String then
 442                --  This label is part of the string type
 443
 444                Found := True;
 445
 446                if Choices.Table (Choice).Already_Used then
 447                   --  But it has already appeared in a choice list for this
 448                   --  case construction; report an error.
 449
 450                   Error_Msg_Name_1 := Choice_String;
 451                   Error_Msg ("duplicate case label {", Token_Ptr);
 452                else
 453                   Choices.Table (Choice).Already_Used := True;
 454                end if;
 455
 456                exit;
 457             end if;
 458          end loop;
 459
 460          --  If the label is not part of the string list, report an error
 461
 462          if not Found then
 463             Error_Msg_Name_1 := Choice_String;
 464             Error_Msg ("illegal case label {", Token_Ptr);
 465          end if;
 466
 467          --  Scan past the label
 468
 469          Scan;
 470
 471          --  If there is no '|', we are done
 472
 473          if Token = Tok_Vertical_Bar then
 474             --  Otherwise, declare the node of the next choice, link it to
 475             --  Current_Choice and set Current_Choice to this new node.
 476
 477             Next_Choice :=
 478               Default_Project_Node (Of_Kind       => N_Literal_String,
 479                                     And_Expr_Kind => Single);
 480             Set_Next_Literal_String (Current_Choice, To => Next_Choice);
 481             Current_Choice := Next_Choice;
 482             Scan;
 483          else
 484             exit;
 485          end if;
 486       end loop;
 487    end Parse_Choice_List;
 488
 489    ----------------------
 490    -- Parse_Expression --
 491    ----------------------
 492
 493    procedure Parse_Expression
 494      (Expression      : out Project_Node_Id;
 495       Current_Project : Project_Node_Id;
 496       Current_Package : Project_Node_Id;
 497       Optional_Index  : Boolean)
 498    is
 499       First_Term      : Project_Node_Id := Empty_Node;
 500       Expression_Kind : Variable_Kind := Undefined;
 501
 502    begin
 503       --  Declare the node of the expression
 504
 505       Expression := Default_Project_Node (Of_Kind => N_Expression);
 506       Set_Location_Of (Expression, To => Token_Ptr);
 507
 508       --  Parse the term or terms of the expression
 509
 510       Terms (Term            => First_Term,
 511              Expr_Kind       => Expression_Kind,
 512              Current_Project => Current_Project,
 513              Current_Package => Current_Package,
 514              Optional_Index  => Optional_Index);
 515
 516       --  Set the first term and the expression kind
 517
 518       Set_First_Term (Expression, To => First_Term);
 519       Set_Expression_Kind_Of (Expression, To => Expression_Kind);
 520    end Parse_Expression;
 521
 522    ----------------------------
 523    -- Parse_String_Type_List --
 524    ----------------------------
 525
 526    procedure Parse_String_Type_List (First_String : out Project_Node_Id) is
 527       Last_String  : Project_Node_Id := Empty_Node;
 528       Next_String  : Project_Node_Id := Empty_Node;
 529       String_Value : Name_Id         := No_Name;
 530
 531    begin
 532       --  Declare the node of the first string
 533
 534       First_String :=
 535         Default_Project_Node (Of_Kind       => N_Literal_String,
 536                               And_Expr_Kind => Single);
 537
 538       --  Initially, Last_String is the same as First_String
 539
 540       Last_String := First_String;
 541
 542       loop
 543          Expect (Tok_String_Literal, "literal string");
 544          exit when Token /= Tok_String_Literal;
 545          String_Value := Token_Name;
 546
 547          --  Give its string value to Last_String
 548
 549          Set_String_Value_Of (Last_String, To => String_Value);
 550          Set_Location_Of (Last_String, To => Token_Ptr);
 551
 552          --  Now, check if the string is already part of the string type
 553
 554          declare
 555             Current : Project_Node_Id := First_String;
 556
 557          begin
 558             while Current /= Last_String loop
 559                if String_Value_Of (Current) = String_Value then
 560                   --  This is a repetition, report an error
 561
 562                   Error_Msg_Name_1 := String_Value;
 563                   Error_Msg ("duplicate value { in type", Token_Ptr);
 564                   exit;
 565                end if;
 566
 567                Current := Next_Literal_String (Current);
 568             end loop;
 569          end;
 570
 571          --  Scan past the literal string
 572
 573          Scan;
 574
 575          --  If there is no comma following the literal string, we are done
 576
 577          if Token /= Tok_Comma then
 578             exit;
 579
 580          else
 581             --  Declare the next string, link it to Last_String and set
 582             --  Last_String to its node.
 583
 584             Next_String :=
 585               Default_Project_Node (Of_Kind       => N_Literal_String,
 586                                     And_Expr_Kind => Single);
 587             Set_Next_Literal_String (Last_String, To => Next_String);
 588             Last_String := Next_String;
 589             Scan;
 590          end if;
 591       end loop;
 592    end Parse_String_Type_List;
 593
 594    ------------------------------
 595    -- Parse_Variable_Reference --
 596    ------------------------------
 597
 598    procedure Parse_Variable_Reference
 599      (Variable        : out Project_Node_Id;
 600       Current_Project : Project_Node_Id;
 601       Current_Package : Project_Node_Id)
 602    is
 603       Current_Variable : Project_Node_Id := Empty_Node;
 604
 605       The_Package : Project_Node_Id := Current_Package;
 606       The_Project : Project_Node_Id := Current_Project;
 607
 608       Specified_Project : Project_Node_Id   := Empty_Node;
 609       Specified_Package : Project_Node_Id   := Empty_Node;
 610       Look_For_Variable : Boolean           := True;
 611       First_Attribute   : Attribute_Node_Id := Empty_Attribute;
 612       Variable_Name     : Name_Id;
 613
 614    begin
 615       Names.Init;
 616
 617       loop
 618          Expect (Tok_Identifier, "identifier");
 619
 620          if Token /= Tok_Identifier then
 621             Look_For_Variable := False;
 622             exit;
 623          end if;
 624
 625          Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr));
 626          Scan;
 627          exit when Token /= Tok_Dot;
 628          Scan;
 629       end loop;
 630
 631       if Look_For_Variable then
 632
 633          if Token = Tok_Apostrophe then
 634
 635             --  Attribute reference
 636
 637             case Names.Last is
 638                when 0 =>
 639
 640                   --  Cannot happen
 641
 642                   null;
 643
 644                when 1 =>
 645                   --  This may be a project name or a package name.
 646                   --  Project name have precedence.
 647
 648                   --  First, look if it can be a package name
 649
 650                   First_Attribute :=
 651                     First_Attribute_Of
 652                       (Package_Node_Id_Of (Names.Table (1).Name));
 653
 654                   --  Now, look if it can be a project name
 655
 656                   The_Project := Imported_Or_Extended_Project_Of
 657                     (Current_Project, Names.Table (1).Name);
 658
 659                   if The_Project = Empty_Node then
 660                      --  If it is neither a project name nor a package name,
 661                      --  report an error
 662
 663                      if First_Attribute = Empty_Attribute then
 664                         Error_Msg_Name_1 := Names.Table (1).Name;
 665                         Error_Msg ("unknown project %",
 666                                    Names.Table (1).Location);
 667                         First_Attribute := Attribute_First;
 668
 669                      else
 670                         --  If it is a package name, check if the package
 671                         --  has already been declared in the current project.
 672
 673                         The_Package := First_Package_Of (Current_Project);
 674
 675                         while The_Package /= Empty_Node
 676                           and then Name_Of (The_Package) /=
 677                           Names.Table (1).Name
 678                         loop
 679                            The_Package :=
 680                              Next_Package_In_Project (The_Package);
 681                         end loop;
 682
 683                         --  If it has not been already declared, report an
 684                         --  error.
 685
 686                         if The_Package = Empty_Node then
 687                            Error_Msg_Name_1 := Names.Table (1).Name;
 688                            Error_Msg ("package % not yet defined",
 689                                       Names.Table (1).Location);
 690                         end if;
 691                      end if;
 692
 693                   else
 694                      --  It is a project name
 695
 696                      First_Attribute := Attribute_First;
 697                      The_Package     := Empty_Node;
 698                   end if;
 699
 700                when others =>
 701
 702                   --  We have either a project name made of several simple
 703                   --  names (long project), or a project name (short project)
 704                   --  followed by a package name. The long project name has
 705                   --  precedence.
 706
 707                   declare
 708                      Short_Project : Name_Id;
 709                      Long_Project  : Name_Id;
 710
 711                   begin
 712                      --  Clear the Buffer
 713
 714                      Buffer_Last := 0;
 715
 716                      --  Get the name of the short project
 717
 718                      for Index in 1 .. Names.Last - 1 loop
 719                         Add_To_Buffer
 720                           (Get_Name_String (Names.Table (Index).Name));
 721
 722                         if Index /= Names.Last - 1 then
 723                            Add_To_Buffer (".");
 724                         end if;
 725                      end loop;
 726
 727                      Name_Len := Buffer_Last;
 728                      Name_Buffer (1 .. Buffer_Last) :=
 729                        Buffer (1 .. Buffer_Last);
 730                      Short_Project := Name_Find;
 731
 732                      --  Now, add the last simple name to get the name of the
 733                      --  long project.
 734
 735                      Add_To_Buffer (".");
 736                      Add_To_Buffer
 737                        (Get_Name_String (Names.Table (Names.Last).Name));
 738                      Name_Len := Buffer_Last;
 739                      Name_Buffer (1 .. Buffer_Last) :=
 740                        Buffer (1 .. Buffer_Last);
 741                      Long_Project := Name_Find;
 742
 743                      --  Check if the long project is imported or extended
 744
 745                      The_Project := Imported_Or_Extended_Project_Of
 746                                       (Current_Project, Long_Project);
 747
 748                      --  If the long project exists, then this is the prefix
 749                      --  of the attribute.
 750
 751                      if The_Project /= Empty_Node then
 752                         First_Attribute := Attribute_First;
 753                         The_Package     := Empty_Node;
 754
 755                      else
 756                         --  Otherwise, check if the short project is imported
 757                         --  or extended.
 758
 759                         The_Project := Imported_Or_Extended_Project_Of
 760                                          (Current_Project, Short_Project);
 761
 762                         --  If the short project does not exist, we report an
 763                         --  error.
 764
 765                         if The_Project = Empty_Node then
 766                            Error_Msg_Name_1 := Long_Project;
 767                            Error_Msg_Name_2 := Short_Project;
 768                            Error_Msg ("unknown projects % or %",
 769                                       Names.Table (1).Location);
 770                            The_Package := Empty_Node;
 771                            First_Attribute := Attribute_First;
 772
 773                         else
 774                            --  Now, we check if the package has been declared
 775                            --  in this project.
 776
 777                            The_Package := First_Package_Of (The_Project);
 778                            while The_Package /= Empty_Node
 779                              and then Name_Of (The_Package) /=
 780                              Names.Table (Names.Last).Name
 781                            loop
 782                               The_Package :=
 783                                 Next_Package_In_Project (The_Package);
 784                            end loop;
 785
 786                            --  If it has not, then we report an error
 787
 788                            if The_Package = Empty_Node then
 789                               Error_Msg_Name_1 :=
 790                                 Names.Table (Names.Last).Name;
 791                               Error_Msg_Name_2 := Short_Project;
 792                               Error_Msg ("package % not declared in project %",
 793                                          Names.Table (Names.Last).Location);
 794                               First_Attribute := Attribute_First;
 795
 796                            else
 797                               --  Otherwise, we have the correct project and
 798                               --  package.
 799
 800                               First_Attribute :=
 801                                 First_Attribute_Of
 802                                   (Package_Id_Of (The_Package));
 803                            end if;
 804                         end if;
 805                      end if;
 806                   end;
 807             end case;
 808
 809             Attribute_Reference
 810               (Variable,
 811                Current_Project => The_Project,
 812                Current_Package => The_Package,
 813                First_Attribute => First_Attribute);
 814             return;
 815          end if;
 816       end if;
 817
 818       Variable :=
 819         Default_Project_Node (Of_Kind => N_Variable_Reference);
 820
 821       if Look_For_Variable then
 822          case Names.Last is
 823             when 0 =>
 824
 825                --  Cannot happen
 826
 827                null;
 828
 829             when 1 =>
 830
 831                --  Simple variable name
 832
 833                Set_Name_Of (Variable, To => Names.Table (1).Name);
 834
 835             when 2 =>
 836
 837                --  Variable name with a simple name prefix that can be
 838                --  a project name or a package name. Project names have
 839                --  priority over package names.
 840
 841                Set_Name_Of (Variable, To => Names.Table (2).Name);
 842
 843                --  Check if it can be a package name
 844
 845                The_Package := First_Package_Of (Current_Project);
 846
 847                while The_Package /= Empty_Node
 848                  and then Name_Of (The_Package) /= Names.Table (1).Name
 849                loop
 850                   The_Package := Next_Package_In_Project (The_Package);
 851                end loop;
 852
 853                --  Now look for a possible project name
 854
 855                The_Project := Imported_Or_Extended_Project_Of
 856                                 (Current_Project, Names.Table (1).Name);
 857
 858                if The_Project /= Empty_Node then
 859                   Specified_Project := The_Project;
 860
 861                elsif The_Package = Empty_Node then
 862                   Error_Msg_Name_1 := Names.Table (1).Name;
 863                   Error_Msg ("unknown package or project %",
 864                              Names.Table (1).Location);
 865                   Look_For_Variable := False;
 866
 867                else
 868                   Specified_Package := The_Package;
 869                end if;
 870
 871             when others =>
 872
 873                --  Variable name with a prefix that is either a project name
 874                --  made of several simple names, or a project name followed
 875                --  by a package name.
 876
 877                Set_Name_Of (Variable, To => Names.Table (Names.Last).Name);
 878
 879                declare
 880                   Short_Project : Name_Id;
 881                   Long_Project  : Name_Id;
 882
 883                begin
 884                   --  First, we get the two possible project names
 885
 886                   --  Clear the buffer
 887
 888                   Buffer_Last := 0;
 889
 890                   --  Add all the simple names, except the last two
 891
 892                   for Index in 1 .. Names.Last - 2 loop
 893                      Add_To_Buffer
 894                        (Get_Name_String (Names.Table (Index).Name));
 895
 896                      if Index /= Names.Last - 2 then
 897                         Add_To_Buffer (".");
 898                      end if;
 899                   end loop;
 900
 901                   Name_Len := Buffer_Last;
 902                   Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
 903                   Short_Project := Name_Find;
 904
 905                   --  Add the simple name before the name of the variable
 906
 907                   Add_To_Buffer (".");
 908                   Add_To_Buffer
 909                     (Get_Name_String (Names.Table (Names.Last - 1).Name));
 910                   Name_Len := Buffer_Last;
 911                   Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
 912                   Long_Project := Name_Find;
 913
 914                   --  Check if the prefix is the name of an imported or
 915                   --  extended project.
 916
 917                   The_Project := Imported_Or_Extended_Project_Of
 918                                    (Current_Project, Long_Project);
 919
 920                   if The_Project /= Empty_Node then
 921                      Specified_Project := The_Project;
 922
 923                   else
 924                      --  Now check if the prefix may be a project name followed
 925                      --  by a package name.
 926
 927                      --  First check for a possible project name
 928
 929                      The_Project := Imported_Or_Extended_Project_Of
 930                                    (Current_Project, Short_Project);
 931
 932                      if The_Project = Empty_Node then
 933                         --  Unknown prefix, report an error
 934
 935                         Error_Msg_Name_1 := Long_Project;
 936                         Error_Msg_Name_2 := Short_Project;
 937                         Error_Msg ("unknown projects % or %",
 938                                    Names.Table (1).Location);
 939                         Look_For_Variable := False;
 940
 941                      else
 942                         Specified_Project := The_Project;
 943
 944                         --  Now look for the package in this project
 945
 946                         The_Package := First_Package_Of (The_Project);
 947
 948                         while The_Package /= Empty_Node
 949                           and then Name_Of (The_Package) /=
 950                                               Names.Table (Names.Last - 1).Name
 951                         loop
 952                            The_Package :=
 953                              Next_Package_In_Project (The_Package);
 954                         end loop;
 955
 956                         if The_Package = Empty_Node then
 957                            --  The package does not vexist, report an error
 958
 959                            Error_Msg_Name_1 := Names.Table (2).Name;
 960                            Error_Msg ("unknown package %",
 961                                    Names.Table (Names.Last - 1).Location);
 962                            Look_For_Variable := False;
 963
 964                         else
 965                            Specified_Package := The_Package;
 966                         end if;
 967                      end if;
 968                   end if;
 969                end;
 970          end case;
 971       end if;
 972
 973       if Look_For_Variable then
 974          Variable_Name := Name_Of (Variable);
 975          Set_Project_Node_Of (Variable, To => Specified_Project);
 976          Set_Package_Node_Of (Variable, To => Specified_Package);
 977
 978          if Specified_Project /= Empty_Node then
 979             The_Project := Specified_Project;
 980
 981          else
 982             The_Project := Current_Project;
 983          end if;
 984
 985          Current_Variable := Empty_Node;
 986
 987          --  Look for this variable
 988
 989          --  If a package was specified, check if the variable has been
 990          --  declared in this package.
 991
 992          if Specified_Package /= Empty_Node then
 993             Current_Variable := First_Variable_Of (Specified_Package);
 994
 995             while Current_Variable /= Empty_Node
 996               and then
 997               Name_Of (Current_Variable) /= Variable_Name
 998             loop
 999                Current_Variable := Next_Variable (Current_Variable);
1000             end loop;
1001
1002          else
1003             --  Otherwise, if no project has been specified and we are in
1004             --  a package, first check if the variable has been declared in
1005             --  the package.
1006
1007             if Specified_Project = Empty_Node
1008               and then Current_Package /= Empty_Node
1009             then
1010                Current_Variable := First_Variable_Of (Current_Package);
1011
1012                while Current_Variable /= Empty_Node
1013                  and then Name_Of (Current_Variable) /= Variable_Name
1014                loop
1015                   Current_Variable := Next_Variable (Current_Variable);
1016                end loop;
1017             end if;
1018
1019             --  If we have not found the variable in the package, check if the
1020             --  variable has been declared in the project.
1021
1022             if Current_Variable = Empty_Node then
1023                Current_Variable := First_Variable_Of (The_Project);
1024
1025                while Current_Variable /= Empty_Node
1026                  and then Name_Of (Current_Variable) /= Variable_Name
1027                loop
1028                   Current_Variable := Next_Variable (Current_Variable);
1029                end loop;
1030             end if;
1031          end if;
1032
1033          --  If the variable was not found, report an error
1034
1035          if Current_Variable = Empty_Node then
1036             Error_Msg_Name_1 := Variable_Name;
1037             Error_Msg
1038               ("unknown variable %", Names.Table (Names.Last).Location);
1039          end if;
1040       end if;
1041
1042       if Current_Variable /= Empty_Node then
1043          Set_Expression_Kind_Of
1044            (Variable, To => Expression_Kind_Of (Current_Variable));
1045
1046          if Kind_Of (Current_Variable) = N_Typed_Variable_Declaration then
1047             Set_String_Type_Of
1048               (Variable, To => String_Type_Of (Current_Variable));
1049          end if;
1050       end if;
1051
1052       --  If the variable is followed by a left parenthesis, report an error
1053       --  but attempt to scan the index.
1054
1055       if Token = Tok_Left_Paren then
1056          Error_Msg ("\variables cannot be associative arrays", Token_Ptr);
1057          Scan;
1058          Expect (Tok_String_Literal, "literal string");
1059
1060          if Token = Tok_String_Literal then
1061             Scan;
1062             Expect (Tok_Right_Paren, "`)`");
1063
1064             if Token = Tok_Right_Paren then
1065                Scan;
1066             end if;
1067          end if;
1068       end if;
1069    end Parse_Variable_Reference;
1070
1071    ---------------------------------
1072    -- Start_New_Case_Construction --
1073    ---------------------------------
1074
1075    procedure Start_New_Case_Construction (String_Type  : Project_Node_Id) is
1076       Current_String : Project_Node_Id;
1077
1078    begin
1079       --  Set Choice_First, depending on whether is the first case
1080       --  construction or not.
1081
1082       if Choice_First = 0 then
1083          Choice_First := 1;
1084          Choices.Set_Last (First_Choice_Node_Id);
1085       else
1086          Choice_First := Choices.Last + 1;
1087       end if;
1088
1089       --  Add to table Choices the literal of the string type
1090
1091       if String_Type /= Empty_Node then
1092          Current_String := First_Literal_String (String_Type);
1093
1094          while Current_String /= Empty_Node loop
1095             Add (This_String => String_Value_Of (Current_String));
1096             Current_String := Next_Literal_String (Current_String);
1097          end loop;
1098       end if;
1099
1100       --  Set the value of the last choice in table Choice_Lasts
1101
1102       Choice_Lasts.Increment_Last;
1103       Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
1104
1105    end Start_New_Case_Construction;
1106
1107    -----------
1108    -- Terms --
1109    -----------
1110
1111    procedure Terms
1112      (Term            : out Project_Node_Id;
1113       Expr_Kind       : in out Variable_Kind;
1114       Current_Project : Project_Node_Id;
1115       Current_Package : Project_Node_Id;
1116       Optional_Index  : Boolean)
1117    is
1118       Next_Term          : Project_Node_Id := Empty_Node;
1119       Term_Id            : Project_Node_Id := Empty_Node;
1120       Current_Expression : Project_Node_Id := Empty_Node;
1121       Next_Expression    : Project_Node_Id := Empty_Node;
1122       Current_Location   : Source_Ptr      := No_Location;
1123       Reference          : Project_Node_Id := Empty_Node;
1124
1125    begin
1126       --  Declare a new node for the term
1127
1128       Term := Default_Project_Node (Of_Kind => N_Term);
1129       Set_Location_Of (Term, To => Token_Ptr);
1130
1131       case Token is
1132          when Tok_Left_Paren =>
1133
1134             --  If we have a left parenthesis and we don't know the expression
1135             --  kind, then this is a string list.
1136
1137             case Expr_Kind is
1138                when Undefined =>
1139                   Expr_Kind := List;
1140
1141                when List =>
1142                   null;
1143
1144                when Single =>
1145
1146                   --  If we already know that this is a single string, report
1147                   --  an error, but set the expression kind to string list to
1148                   --  avoid several errors.
1149
1150                   Expr_Kind := List;
1151                   Error_Msg
1152                     ("literal string list cannot appear in a string",
1153                      Token_Ptr);
1154             end case;
1155
1156             --  Declare a new node for this literal string list
1157
1158             Term_Id := Default_Project_Node
1159               (Of_Kind => N_Literal_String_List,
1160                And_Expr_Kind => List);
1161             Set_Current_Term (Term, To => Term_Id);
1162             Set_Location_Of (Term, To => Token_Ptr);
1163
1164             --  Scan past the left parenthesis
1165
1166             Scan;
1167
1168             --  If the left parenthesis is immediately followed by a right
1169             --  parenthesis, the literal string list is empty.
1170
1171             if Token = Tok_Right_Paren then
1172                Scan;
1173
1174             else
1175                --  Otherwise, we parse the expression(s) in the literal string
1176                --  list.
1177
1178                loop
1179                   Current_Location := Token_Ptr;
1180                   Parse_Expression (Expression      => Next_Expression,
1181                                     Current_Project => Current_Project,
1182                                     Current_Package => Current_Package,
1183                                     Optional_Index  => Optional_Index);
1184
1185                   --  The expression kind is String list, report an error
1186
1187                   if Expression_Kind_Of (Next_Expression) = List then
1188                      Error_Msg ("single expression expected",
1189                                 Current_Location);
1190                   end if;
1191
1192                   --  If Current_Expression is empty, it means that the
1193                   --  expression is the first in the string list.
1194
1195                   if Current_Expression = Empty_Node then
1196                      Set_First_Expression_In_List
1197                        (Term_Id, To => Next_Expression);
1198                   else
1199                      Set_Next_Expression_In_List
1200                        (Current_Expression, To => Next_Expression);
1201                   end if;
1202
1203                   Current_Expression := Next_Expression;
1204
1205                   --  If there is a comma, continue with the next expression
1206
1207                   exit when Token /= Tok_Comma;
1208                   Scan; -- past the comma
1209                end loop;
1210
1211                --  We expect a closing right parenthesis
1212
1213                Expect (Tok_Right_Paren, "`)`");
1214
1215                if Token = Tok_Right_Paren then
1216                   Scan;
1217                end if;
1218             end if;
1219
1220          when Tok_String_Literal =>
1221
1222             --  If we don't know the expression kind (first term), then it is
1223             --  a simple string.
1224
1225             if Expr_Kind = Undefined then
1226                Expr_Kind := Single;
1227             end if;
1228
1229             --  Declare a new node for the string literal
1230
1231             Term_Id := Default_Project_Node (Of_Kind => N_Literal_String);
1232             Set_Current_Term (Term, To => Term_Id);
1233             Set_String_Value_Of (Term_Id, To => Token_Name);
1234
1235             --  Scan past the string literal
1236
1237             Scan;
1238
1239             --  Check for possible index expression
1240
1241             if Token = Tok_At then
1242                if not Optional_Index then
1243                   Error_Msg ("index not allowed here", Token_Ptr);
1244                   Scan;
1245
1246                   if Token = Tok_Integer_Literal then
1247                      Scan;
1248                   end if;
1249
1250                --  Set the index value
1251
1252                else
1253                   Scan;
1254                   Expect (Tok_Integer_Literal, "integer literal");
1255
1256                   if Token = Tok_Integer_Literal then
1257                      declare
1258                         Index : constant Int := UI_To_Int (Int_Literal_Value);
1259                      begin
1260                         if Index = 0 then
1261                            Error_Msg ("index cannot be zero", Token_Ptr);
1262                         else
1263                            Set_Source_Index_Of (Term_Id, To => Index);
1264                         end if;
1265                      end;
1266
1267                      Scan;
1268                   end if;
1269                end if;
1270             end if;
1271
1272          when Tok_Identifier =>
1273             Current_Location := Token_Ptr;
1274
1275             --  Get the variable or attribute reference
1276
1277             Parse_Variable_Reference
1278               (Variable        => Reference,
1279                Current_Project => Current_Project,
1280                Current_Package => Current_Package);
1281             Set_Current_Term (Term, To => Reference);
1282
1283             if Reference /= Empty_Node then
1284
1285                --  If we don't know the expression kind (first term), then it
1286                --  has the kind of the variable or attribute reference.
1287
1288                if Expr_Kind = Undefined then
1289                   Expr_Kind := Expression_Kind_Of (Reference);
1290
1291                elsif Expr_Kind = Single
1292                  and then Expression_Kind_Of (Reference) = List
1293                then
1294                   --  If the expression is a single list, and the reference is
1295                   --  a string list, report an error, and set the expression
1296                   --  kind to string list to avoid multiple errors.
1297
1298                   Expr_Kind := List;
1299                   Error_Msg
1300                     ("list variable cannot appear in single string expression",
1301                      Current_Location);
1302                end if;
1303             end if;
1304
1305          when Tok_Project =>
1306
1307             --  project can appear in an expression as the prefix of an
1308             --  attribute reference of the current project.
1309
1310             Current_Location := Token_Ptr;
1311             Scan;
1312             Expect (Tok_Apostrophe, "`'`");
1313
1314             if Token = Tok_Apostrophe then
1315                Attribute_Reference
1316                  (Reference       => Reference,
1317                   First_Attribute => Prj.Attr.Attribute_First,
1318                   Current_Project => Current_Project,
1319                   Current_Package => Empty_Node);
1320                Set_Current_Term (Term, To => Reference);
1321             end if;
1322
1323             --  Same checks as above for the expression kind
1324
1325             if Reference /= Empty_Node then
1326                if Expr_Kind = Undefined then
1327                   Expr_Kind := Expression_Kind_Of (Reference);
1328
1329                elsif Expr_Kind = Single
1330                  and then Expression_Kind_Of (Reference) = List
1331                then
1332                   Error_Msg
1333                     ("lists cannot appear in single string expression",
1334                      Current_Location);
1335                end if;
1336             end if;
1337
1338          when Tok_External =>
1339             --  An external reference is always a single string
1340
1341             if Expr_Kind = Undefined then
1342                Expr_Kind := Single;
1343             end if;
1344
1345             External_Reference (External_Value => Reference);
1346             Set_Current_Term (Term, To => Reference);
1347
1348          when others =>
1349             Error_Msg ("cannot be part of an expression", Token_Ptr);
1350             Term := Empty_Node;
1351             return;
1352       end case;
1353
1354       --  If there is an '&', call Terms recursively
1355
1356       if Token = Tok_Ampersand then
1357
1358          --  Scan past the '&'
1359
1360          Scan;
1361
1362          Terms (Term            => Next_Term,
1363                 Expr_Kind       => Expr_Kind,
1364                 Current_Project => Current_Project,
1365                 Current_Package => Current_Package,
1366                 Optional_Index  => Optional_Index);
1367
1368          --  And link the next term to this term
1369
1370          Set_Next_Term (Term, To => Next_Term);
1371       end if;
1372    end Terms;
1373
1374 end Prj.Strt;