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