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