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