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