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