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