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