?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* emit-rtl.c (widen_memory_access): New.
[official-gcc.git] / gcc / ada / prj-strt.adb
blob790c632c2cfa5667f6af716d58c2878339fa5f54
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . S T R T --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.12 $
10 -- --
11 -- Copyright (C) 2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
28
29 with Errout; use Errout;
30 with Prj.Attr; use Prj.Attr;
31 with Prj.Tree; use Prj.Tree;
32 with Scans; use Scans;
33 with Sinfo; use Sinfo;
34 with Stringt; use Stringt;
35 with Table;
36 with Types; use Types;
37
38 package body Prj.Strt is
39
40 Initial_Size : constant := 8;
41
42 type Name_Location is record
43 Name : Name_Id := No_Name;
44 Location : Source_Ptr := No_Location;
45 end record;
46 -- Store the identifier and the location of a simple name
47
48 type Name_Range is range 0 .. 3;
49 subtype Name_Index is Name_Range range 1 .. Name_Range'Last;
50 -- A Name may contain up to 3 simple names
51
52 type Names is array (Name_Index) of Name_Location;
53 -- Used to store 1 to 3 simple_names. 2 simple names are for
54 -- <project>.<package>, <project>.<variable> or <package>.<variable>.
55 -- 3 simple names are for <project>.<package>.<variable>.
56
57 type Choice_String is record
58 The_String : String_Id;
59 Already_Used : Boolean := False;
60 end record;
61 -- The string of a case label, and an indication that it has already
62 -- been used (to avoid duplicate case labels).
63
64 Choices_Initial : constant := 10;
65 Choices_Increment : constant := 10;
66
67 Choice_Node_Low_Bound : constant := 0;
68 Choice_Node_High_Bound : constant := 099_999_999; -- In practice, infinite
69
70 type Choice_Node_Id is
71 range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
72
73 First_Choice_Node_Id : constant Choice_Node_Id :=
74 Choice_Node_Low_Bound;
75
76 Empty_Choice : constant Choice_Node_Id :=
77 Choice_Node_Low_Bound;
78
79 First_Choice_Id : constant Choice_Node_Id := First_Choice_Node_Id + 1;
80
81 package Choices is
82 new Table.Table (Table_Component_Type => Choice_String,
83 Table_Index_Type => Choice_Node_Id,
84 Table_Low_Bound => First_Choice_Node_Id,
85 Table_Initial => Choices_Initial,
86 Table_Increment => Choices_Increment,
87 Table_Name => "Prj.Strt.Choices");
88 -- Used to store the case labels and check that there is no duplicate.
89
90 package Choice_Lasts is
91 new Table.Table (Table_Component_Type => Choice_Node_Id,
92 Table_Index_Type => Nat,
93 Table_Low_Bound => 1,
94 Table_Initial => 3,
95 Table_Increment => 3,
96 Table_Name => "Prj.Strt.Choice_Lasts");
97 -- Used to store the indices of the choices in table Choices,
98 -- to distinguish nested case constructions.
99
100 Choice_First : Choice_Node_Id := 0;
101 -- Index in table Choices of the first case label of the current
102 -- case construction.
103 -- 0 means no current case construction.
104
105 procedure Add (This_String : String_Id);
106 -- Add a string to the case label list, indicating that it has not
107 -- yet been used.
108
109 procedure External_Reference (External_Value : out Project_Node_Id);
110 -- Parse an external reference. Current token is "external".
111
112 procedure Attribute_Reference
113 (Reference : out Project_Node_Id;
114 First_Attribute : Attribute_Node_Id;
115 Current_Project : Project_Node_Id;
116 Current_Package : Project_Node_Id);
117 -- Parse an attribute reference. Current token is an apostrophe.
118
119 procedure Terms
120 (Term : out Project_Node_Id;
121 Expr_Kind : in out Variable_Kind;
122 Current_Project : Project_Node_Id;
123 Current_Package : Project_Node_Id);
124 -- Recursive procedure to parse one term or several terms concatenated
125 -- using "&".
126
127 ---------
128 -- Add --
129 ---------
130
131 procedure Add (This_String : String_Id) is
132 begin
133 Choices.Increment_Last;
134 Choices.Table (Choices.Last) :=
135 (The_String => This_String,
136 Already_Used => False);
137 end Add;
138
139 -------------------------
140 -- Attribute_Reference --
141 -------------------------
142
143 procedure Attribute_Reference
144 (Reference : out Project_Node_Id;
145 First_Attribute : Attribute_Node_Id;
146 Current_Project : Project_Node_Id;
147 Current_Package : Project_Node_Id)
148 is
149 Current_Attribute : Attribute_Node_Id := First_Attribute;
150
151 begin
152 Reference := Default_Project_Node (Of_Kind => N_Attribute_Reference);
153 Set_Location_Of (Reference, To => Token_Ptr);
154 Scan; -- past apostrophe
155 Expect (Tok_Identifier, "Identifier");
156
157 if Token = Tok_Identifier then
158 Set_Name_Of (Reference, To => Token_Name);
159
160 while Current_Attribute /= Empty_Attribute
161 and then
162 Attributes.Table (Current_Attribute).Name /= Token_Name
163 loop
164 Current_Attribute := Attributes.Table (Current_Attribute).Next;
165 end loop;
166
167 if Current_Attribute = Empty_Attribute then
168 Error_Msg ("unknown attribute", Token_Ptr);
169 Reference := Empty_Node;
170
171 elsif
172 Attributes.Table (Current_Attribute).Kind_2 = Associative_Array
173 then
174 Error_Msg
175 ("associative array attribute cannot be referenced",
176 Token_Ptr);
177 Reference := Empty_Node;
178
179 else
180 Set_Project_Node_Of (Reference, To => Current_Project);
181 Set_Package_Node_Of (Reference, To => Current_Package);
182 Set_Expression_Kind_Of
183 (Reference, To => Attributes.Table (Current_Attribute).Kind_1);
184 Scan;
185 end if;
186 end if;
187 end Attribute_Reference;
188
189 ---------------------------
190 -- End_Case_Construction --
191 ---------------------------
192
193 procedure End_Case_Construction is
194 begin
195 if Choice_Lasts.Last = 1 then
196 Choice_Lasts.Set_Last (0);
197 Choices.Set_Last (First_Choice_Node_Id);
198 Choice_First := 0;
199
200 elsif Choice_Lasts.Last = 2 then
201 Choice_Lasts.Set_Last (1);
202 Choices.Set_Last (Choice_Lasts.Table (1));
203 Choice_First := 1;
204
205 else
206 Choice_Lasts.Decrement_Last;
207 Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
208 Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
209 end if;
210 end End_Case_Construction;
211
212 ------------------------
213 -- External_Reference --
214 ------------------------
215
216 procedure External_Reference (External_Value : out Project_Node_Id) is
217 Field_Id : Project_Node_Id := Empty_Node;
218
219 begin
220 External_Value :=
221 Default_Project_Node (Of_Kind => N_External_Value,
222 And_Expr_Kind => Single);
223 Set_Location_Of (External_Value, To => Token_Ptr);
224
225 -- The current token is External
226
227 -- Get the left parenthesis
228
229 Scan;
230 Expect (Tok_Left_Paren, "(");
231
232 -- Scan past the left parenthesis
233
234 if Token = Tok_Left_Paren then
235 Scan;
236 end if;
237
238 -- Get the name of the external reference
239
240 Expect (Tok_String_Literal, "literal string");
241
242 if Token = Tok_String_Literal then
243 Field_Id :=
244 Default_Project_Node (Of_Kind => N_Literal_String,
245 And_Expr_Kind => Single);
246 Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
247 Set_External_Reference_Of (External_Value, To => Field_Id);
248
249 -- Scan past the first argument
250
251 Scan;
252
253 case Token is
254
255 when Tok_Right_Paren =>
256
257 -- Scan past the right parenthesis
258 Scan;
259
260 when Tok_Comma =>
261
262 -- Scan past the comma
263
264 Scan;
265
266 Expect (Tok_String_Literal, "literal string");
267
268 -- Get the default
269
270 if Token = Tok_String_Literal then
271 Field_Id :=
272 Default_Project_Node (Of_Kind => N_Literal_String,
273 And_Expr_Kind => Single);
274 Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
275 Set_External_Default_Of (External_Value, To => Field_Id);
276 Scan;
277 Expect (Tok_Right_Paren, ")");
278 end if;
279
280 -- Scan past the right parenthesis
281 if Token = Tok_Right_Paren then
282 Scan;
283 end if;
284
285 when others =>
286 Error_Msg ("',' or ')' expected", Token_Ptr);
287 end case;
288 end if;
289 end External_Reference;
290
291 -----------------------
292 -- Parse_Choice_List --
293 -----------------------
294
295 procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is
296 Current_Choice : Project_Node_Id := Empty_Node;
297 Next_Choice : Project_Node_Id := Empty_Node;
298 Choice_String : String_Id := No_String;
299 Found : Boolean := False;
300
301 begin
302 First_Choice :=
303 Default_Project_Node (Of_Kind => N_Literal_String,
304 And_Expr_Kind => Single);
305 Current_Choice := First_Choice;
306
307 loop
308 Expect (Tok_String_Literal, "literal string");
309 exit when Token /= Tok_String_Literal;
310 Set_Location_Of (Current_Choice, To => Token_Ptr);
311 Choice_String := Strval (Token_Node);
312 Set_String_Value_Of (Current_Choice, To => Choice_String);
313
314 Found := False;
315 for Choice in Choice_First .. Choices.Last loop
316 if String_Equal (Choices.Table (Choice).The_String,
317 Choice_String)
318 then
319 Found := True;
320
321 if Choices.Table (Choice).Already_Used then
322 Error_Msg ("duplicate case label", Token_Ptr);
323 else
324 Choices.Table (Choice).Already_Used := True;
325 end if;
326
327 exit;
328 end if;
329 end loop;
330
331 if not Found then
332 Error_Msg ("illegal case label", Token_Ptr);
333 end if;
334
335 Scan;
336
337 if Token = Tok_Vertical_Bar then
338 Next_Choice :=
339 Default_Project_Node (Of_Kind => N_Literal_String,
340 And_Expr_Kind => Single);
341 Set_Next_Literal_String (Current_Choice, To => Next_Choice);
342 Current_Choice := Next_Choice;
343 Scan;
344 else
345 exit;
346 end if;
347 end loop;
348 end Parse_Choice_List;
349
350 ----------------------
351 -- Parse_Expression --
352 ----------------------
353
354 procedure Parse_Expression
355 (Expression : out Project_Node_Id;
356 Current_Project : Project_Node_Id;
357 Current_Package : Project_Node_Id)
358 is
359 First_Term : Project_Node_Id := Empty_Node;
360 Expression_Kind : Variable_Kind := Undefined;
361
362 begin
363 Expression := Default_Project_Node (Of_Kind => N_Expression);
364 Set_Location_Of (Expression, To => Token_Ptr);
365 Terms (Term => First_Term,
366 Expr_Kind => Expression_Kind,
367 Current_Project => Current_Project,
368 Current_Package => Current_Package);
369 Set_First_Term (Expression, To => First_Term);
370 Set_Expression_Kind_Of (Expression, To => Expression_Kind);
371 end Parse_Expression;
372
373 ----------------------------
374 -- Parse_String_Type_List --
375 ----------------------------
376
377 procedure Parse_String_Type_List (First_String : out Project_Node_Id) is
378 Last_String : Project_Node_Id := Empty_Node;
379 Next_String : Project_Node_Id := Empty_Node;
380 String_Value : String_Id := No_String;
381
382 begin
383 First_String :=
384 Default_Project_Node (Of_Kind => N_Literal_String,
385 And_Expr_Kind => Single);
386 Last_String := First_String;
387
388 loop
389 Expect (Tok_String_Literal, "literal string");
390 exit when Token /= Tok_String_Literal;
391 String_Value := Strval (Token_Node);
392 Set_String_Value_Of (Last_String, To => String_Value);
393 Set_Location_Of (Last_String, To => Token_Ptr);
394
395 declare
396 Current : Project_Node_Id := First_String;
397
398 begin
399 while Current /= Last_String loop
400 if String_Equal (String_Value_Of (Current), String_Value) then
401 Error_Msg ("duplicate value in type", Token_Ptr);
402 exit;
403 end if;
404
405 Current := Next_Literal_String (Current);
406 end loop;
407 end;
408
409 Scan;
410
411 if Token /= Tok_Comma then
412 exit;
413
414 else
415 Next_String :=
416 Default_Project_Node (Of_Kind => N_Literal_String,
417 And_Expr_Kind => Single);
418 Set_Next_Literal_String (Last_String, To => Next_String);
419 Last_String := Next_String;
420 Scan;
421 end if;
422 end loop;
423 end Parse_String_Type_List;
424
425 ------------------------------
426 -- Parse_Variable_Reference --
427 ------------------------------
428
429 procedure Parse_Variable_Reference
430 (Variable : out Project_Node_Id;
431 Current_Project : Project_Node_Id;
432 Current_Package : Project_Node_Id)
433 is
434 The_Names : Names;
435 Last_Name : Name_Range := 0;
436 Current_Variable : Project_Node_Id := Empty_Node;
437
438 The_Package : Project_Node_Id := Current_Package;
439 The_Project : Project_Node_Id := Current_Project;
440
441 Specified_Project : Project_Node_Id := Empty_Node;
442 Specified_Package : Project_Node_Id := Empty_Node;
443 Look_For_Variable : Boolean := True;
444 First_Attribute : Attribute_Node_Id := Empty_Attribute;
445 Variable_Name : Name_Id;
446
447 begin
448 for Index in The_Names'Range loop
449 Expect (Tok_Identifier, "identifier");
450
451 if Token /= Tok_Identifier then
452 Look_For_Variable := False;
453 exit;
454 end if;
455
456 Last_Name := Last_Name + 1;
457 The_Names (Last_Name) :=
458 (Name => Token_Name,
459 Location => Token_Ptr);
460 Scan;
461 exit when Token /= Tok_Dot;
462 Scan;
463 end loop;
464
465 if Look_For_Variable then
466 if Token = Tok_Apostrophe then
467
468 -- Attribute reference
469
470 case Last_Name is
471 when 0 =>
472
473 -- Cannot happen
474
475 null;
476
477 when 1 =>
478 for Index in Package_First .. Package_Attributes.Last loop
479 if Package_Attributes.Table (Index).Name =
480 The_Names (1).Name
481 then
482 First_Attribute :=
483 Package_Attributes.Table (Index).First_Attribute;
484 exit;
485 end if;
486 end loop;
487
488 if First_Attribute /= Empty_Attribute then
489 The_Package := First_Package_Of (Current_Project);
490 while The_Package /= Empty_Node
491 and then Name_Of (The_Package) /= The_Names (1).Name
492 loop
493 The_Package := Next_Package_In_Project (The_Package);
494 end loop;
495
496 if The_Package = Empty_Node then
497 Error_Msg ("package not yet defined",
498 The_Names (1).Location);
499 end if;
500
501 else
502 First_Attribute := Attribute_First;
503 The_Package := Empty_Node;
504
505 declare
506 The_Project_Name_And_Node :
507 constant Tree_Private_Part.Project_Name_And_Node :=
508 Tree_Private_Part.Projects_Htable.Get
509 (The_Names (1).Name);
510
511 use Tree_Private_Part;
512
513 begin
514 if The_Project_Name_And_Node =
515 Tree_Private_Part.No_Project_Name_And_Node
516 then
517 Error_Msg ("unknown project",
518 The_Names (1).Location);
519 else
520 The_Project := The_Project_Name_And_Node.Node;
521 end if;
522 end;
523 end if;
524
525 when 2 =>
526 declare
527 With_Clause : Project_Node_Id :=
528 First_With_Clause_Of (Current_Project);
529
530 begin
531 while With_Clause /= Empty_Node loop
532 The_Project := Project_Node_Of (With_Clause);
533 exit when Name_Of (The_Project) = The_Names (1).Name;
534 With_Clause := Next_With_Clause_Of (With_Clause);
535 end loop;
536
537 if With_Clause = Empty_Node then
538 Error_Msg ("unknown project",
539 The_Names (1).Location);
540 The_Project := Empty_Node;
541 The_Package := Empty_Node;
542 First_Attribute := Attribute_First;
543
544 else
545 The_Package := First_Package_Of (The_Project);
546 while The_Package /= Empty_Node
547 and then Name_Of (The_Package) /= The_Names (2).Name
548 loop
549 The_Package :=
550 Next_Package_In_Project (The_Package);
551 end loop;
552
553 if The_Package = Empty_Node then
554 Error_Msg ("package not declared in project",
555 The_Names (2).Location);
556 First_Attribute := Attribute_First;
557
558 else
559 First_Attribute :=
560 Package_Attributes.Table
561 (Package_Id_Of (The_Package)).First_Attribute;
562 end if;
563 end if;
564 end;
565
566 when 3 =>
567 Error_Msg
568 ("too many single names for an attribute reference",
569 The_Names (1).Location);
570 Scan;
571 Variable := Empty_Node;
572 return;
573 end case;
574
575 Attribute_Reference
576 (Variable,
577 Current_Project => The_Project,
578 Current_Package => The_Package,
579 First_Attribute => First_Attribute);
580 return;
581 end if;
582 end if;
583
584 Variable :=
585 Default_Project_Node (Of_Kind => N_Variable_Reference);
586
587 if Look_For_Variable then
588 case Last_Name is
589 when 0 =>
590
591 -- Cannot happen
592
593 null;
594
595 when 1 =>
596 Set_Name_Of (Variable, To => The_Names (1).Name);
597
598 -- Header comment needed ???
599
600 when 2 =>
601 Set_Name_Of (Variable, To => The_Names (2).Name);
602 The_Package := First_Package_Of (Current_Project);
603
604 while The_Package /= Empty_Node
605 and then Name_Of (The_Package) /= The_Names (1).Name
606 loop
607 The_Package := Next_Package_In_Project (The_Package);
608 end loop;
609
610 if The_Package /= Empty_Node then
611 Specified_Package := The_Package;
612 The_Project := Empty_Node;
613
614 else
615 declare
616 With_Clause : Project_Node_Id :=
617 First_With_Clause_Of (Current_Project);
618
619 begin
620 while With_Clause /= Empty_Node loop
621 The_Project := Project_Node_Of (With_Clause);
622 exit when Name_Of (The_Project) = The_Names (1).Name;
623 With_Clause := Next_With_Clause_Of (With_Clause);
624 end loop;
625
626 if With_Clause = Empty_Node then
627 The_Project :=
628 Modified_Project_Of
629 (Project_Declaration_Of (Current_Project));
630
631 if The_Project /= Empty_Node
632 and then
633 Name_Of (The_Project) /= The_Names (1).Name
634 then
635 The_Project := Empty_Node;
636 end if;
637 end if;
638
639 if The_Project = Empty_Node then
640 Error_Msg ("unknown package or project",
641 The_Names (1).Location);
642 Look_For_Variable := False;
643 else
644 Specified_Project := The_Project;
645 end if;
646 end;
647 end if;
648
649 -- Header comment needed ???
650
651 when 3 =>
652 Set_Name_Of (Variable, To => The_Names (3).Name);
653
654 declare
655 With_Clause : Project_Node_Id :=
656 First_With_Clause_Of (Current_Project);
657
658 begin
659 while With_Clause /= Empty_Node loop
660 The_Project := Project_Node_Of (With_Clause);
661 exit when Name_Of (The_Project) = The_Names (1).Name;
662 With_Clause := Next_With_Clause_Of (With_Clause);
663 end loop;
664
665 if With_Clause = Empty_Node then
666 The_Project :=
667 Modified_Project_Of
668 (Project_Declaration_Of (Current_Project));
669
670 if The_Project /= Empty_Node
671 and then Name_Of (The_Project) /= The_Names (1).Name
672 then
673 The_Project := Empty_Node;
674 end if;
675 end if;
676
677 if The_Project = Empty_Node then
678 Error_Msg ("unknown package or project",
679 The_Names (1).Location);
680 Look_For_Variable := False;
681
682 else
683 Specified_Project := The_Project;
684 The_Package := First_Package_Of (The_Project);
685
686 while The_Package /= Empty_Node
687 and then Name_Of (The_Package) /= The_Names (2).Name
688 loop
689 The_Package := Next_Package_In_Project (The_Package);
690 end loop;
691
692 if The_Package = Empty_Node then
693 Error_Msg ("unknown package",
694 The_Names (2).Location);
695 Look_For_Variable := False;
696
697 else
698 Specified_Package := The_Package;
699 The_Project := Empty_Node;
700 end if;
701 end if;
702 end;
703
704 end case;
705 end if;
706
707 if Look_For_Variable then
708 Variable_Name := Name_Of (Variable);
709 Set_Project_Node_Of (Variable, To => Specified_Project);
710 Set_Package_Node_Of (Variable, To => Specified_Package);
711
712 if The_Package /= Empty_Node then
713 Current_Variable := First_Variable_Of (The_Package);
714
715 while Current_Variable /= Empty_Node
716 and then
717 Name_Of (Current_Variable) /= Variable_Name
718 loop
719 Current_Variable := Next_Variable (Current_Variable);
720 end loop;
721 end if;
722
723 if Current_Variable = Empty_Node
724 and then The_Project /= Empty_Node
725 then
726 Current_Variable := First_Variable_Of (The_Project);
727 while Current_Variable /= Empty_Node
728 and then Name_Of (Current_Variable) /= Variable_Name
729 loop
730 Current_Variable := Next_Variable (Current_Variable);
731 end loop;
732 end if;
733
734 if Current_Variable = Empty_Node then
735 Error_Msg ("unknown variable", The_Names (Last_Name).Location);
736 end if;
737 end if;
738
739 if Current_Variable /= Empty_Node then
740 Set_Expression_Kind_Of
741 (Variable, To => Expression_Kind_Of (Current_Variable));
742
743 if Kind_Of (Current_Variable) = N_Typed_Variable_Declaration then
744 Set_String_Type_Of
745 (Variable, To => String_Type_Of (Current_Variable));
746 end if;
747 end if;
748 end Parse_Variable_Reference;
749
750 ---------------------------------
751 -- Start_New_Case_Construction --
752 ---------------------------------
753
754 procedure Start_New_Case_Construction (String_Type : Project_Node_Id) is
755 Current_String : Project_Node_Id;
756
757 begin
758 if Choice_First = 0 then
759 Choice_First := 1;
760 Choices.Set_Last (First_Choice_Node_Id);
761 else
762 Choice_First := Choices.Last + 1;
763 end if;
764
765 if String_Type /= Empty_Node then
766 Current_String := First_Literal_String (String_Type);
767
768 while Current_String /= Empty_Node loop
769 Add (This_String => String_Value_Of (Current_String));
770 Current_String := Next_Literal_String (Current_String);
771 end loop;
772 end if;
773
774 Choice_Lasts.Increment_Last;
775 Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
776
777 end Start_New_Case_Construction;
778
779 -----------
780 -- Terms --
781 -----------
782
783 procedure Terms (Term : out Project_Node_Id;
784 Expr_Kind : in out Variable_Kind;
785 Current_Project : Project_Node_Id;
786 Current_Package : Project_Node_Id)
787 is
788 Next_Term : Project_Node_Id := Empty_Node;
789 Term_Id : Project_Node_Id := Empty_Node;
790 Current_Expression : Project_Node_Id := Empty_Node;
791 Next_Expression : Project_Node_Id := Empty_Node;
792 Current_Location : Source_Ptr := No_Location;
793 Reference : Project_Node_Id := Empty_Node;
794
795 begin
796 Term := Default_Project_Node (Of_Kind => N_Term);
797 Set_Location_Of (Term, To => Token_Ptr);
798
799 case Token is
800
801 when Tok_Left_Paren =>
802 case Expr_Kind is
803 when Undefined =>
804 Expr_Kind := List;
805 when List =>
806 null;
807 when Single =>
808 Expr_Kind := List;
809 Error_Msg
810 ("literal string list cannot appear in a string",
811 Token_Ptr);
812 end case;
813
814 Term_Id := Default_Project_Node
815 (Of_Kind => N_Literal_String_List,
816 And_Expr_Kind => List);
817 Set_Current_Term (Term, To => Term_Id);
818 Set_Location_Of (Term, To => Token_Ptr);
819
820 Scan;
821 if Token = Tok_Right_Paren then
822 Scan;
823
824 else
825 loop
826 Current_Location := Token_Ptr;
827 Parse_Expression (Expression => Next_Expression,
828 Current_Project => Current_Project,
829 Current_Package => Current_Package);
830
831 if Expression_Kind_Of (Next_Expression) = List then
832 Error_Msg ("single expression expected",
833 Current_Location);
834 end if;
835
836 if Current_Expression = Empty_Node then
837 Set_First_Expression_In_List
838 (Term_Id, To => Next_Expression);
839 else
840 Set_Next_Expression_In_List
841 (Current_Expression, To => Next_Expression);
842 end if;
843
844 Current_Expression := Next_Expression;
845 exit when Token /= Tok_Comma;
846 Scan; -- past the comma
847 end loop;
848
849 Expect (Tok_Right_Paren, "(");
850
851 if Token = Tok_Right_Paren then
852 Scan;
853 end if;
854 end if;
855
856 when Tok_String_Literal =>
857 if Expr_Kind = Undefined then
858 Expr_Kind := Single;
859 end if;
860
861 Term_Id := Default_Project_Node (Of_Kind => N_Literal_String);
862 Set_Current_Term (Term, To => Term_Id);
863 Set_String_Value_Of (Term_Id, To => Strval (Token_Node));
864
865 Scan;
866
867 when Tok_Identifier =>
868 Current_Location := Token_Ptr;
869 Parse_Variable_Reference
870 (Variable => Reference,
871 Current_Project => Current_Project,
872 Current_Package => Current_Package);
873 Set_Current_Term (Term, To => Reference);
874
875 if Reference /= Empty_Node then
876 if Expr_Kind = Undefined then
877 Expr_Kind := Expression_Kind_Of (Reference);
878
879 elsif Expr_Kind = Single
880 and then Expression_Kind_Of (Reference) = List
881 then
882 Expr_Kind := List;
883 Error_Msg
884 ("list variable cannot appear in single string expression",
885 Current_Location);
886 end if;
887 end if;
888
889 when Tok_Project =>
890 Current_Location := Token_Ptr;
891 Scan;
892 Expect (Tok_Apostrophe, "'");
893
894 if Token = Tok_Apostrophe then
895 Attribute_Reference
896 (Reference => Reference,
897 First_Attribute => Prj.Attr.Attribute_First,
898 Current_Project => Current_Project,
899 Current_Package => Empty_Node);
900 Set_Current_Term (Term, To => Reference);
901 end if;
902
903 if Reference /= Empty_Node then
904 if Expr_Kind = Undefined then
905 Expr_Kind := Expression_Kind_Of (Reference);
906
907 elsif Expr_Kind = Single
908 and then Expression_Kind_Of (Reference) = List
909 then
910 Error_Msg
911 ("lists cannot appear in single string expression",
912 Current_Location);
913 end if;
914 end if;
915
916 when Tok_External =>
917 if Expr_Kind = Undefined then
918 Expr_Kind := Single;
919 end if;
920
921 External_Reference (External_Value => Reference);
922 Set_Current_Term (Term, To => Reference);
923
924 when others =>
925 Error_Msg ("cannot be part of an expression", Token_Ptr);
926 Term := Empty_Node;
927 return;
928 end case;
929
930 if Token = Tok_Ampersand then
931 Scan;
932
933 Terms (Term => Next_Term,
934 Expr_Kind => Expr_Kind,
935 Current_Project => Current_Project,
936 Current_Package => Current_Package);
937 Set_Next_Term (Term, To => Next_Term);
938
939 end if;
940
941 end Terms;
942
943 end Prj.Strt;
Mirror of the offical gcc git repository hosted at gcc.gnu.org