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