?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-07-27 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc/alias-decl.git] / gcc / ada / prj-dect.adb
blob5795061eacb46d065153ef83e1565ebd4f513ff0
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . D E C T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2009, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Err_Vars; use Err_Vars;
27
28 with GNAT.Case_Util; use GNAT.Case_Util;
29 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
30
31 with Opt; use Opt;
32 with Prj.Attr; use Prj.Attr;
33 with Prj.Attr.PM; use Prj.Attr.PM;
34 with Prj.Err; use Prj.Err;
35 with Prj.Strt; use Prj.Strt;
36 with Prj.Tree; use Prj.Tree;
37 with Snames;
38 with Uintp; use Uintp;
39
40 with GNAT.Strings;
41
42 package body Prj.Dect is
43
44 use GNAT;
45
46 type Zone is (In_Project, In_Package, In_Case_Construction);
47 -- Used to indicate if we are parsing a package (In_Package),
48 -- a case construction (In_Case_Construction) or none of those two
49 -- (In_Project).
50
51 procedure Parse_Attribute_Declaration
52 (In_Tree : Project_Node_Tree_Ref;
53 Attribute : out Project_Node_Id;
54 First_Attribute : Attribute_Node_Id;
55 Current_Project : Project_Node_Id;
56 Current_Package : Project_Node_Id;
57 Packages_To_Check : String_List_Access;
58 Flags : Processing_Flags);
59 -- Parse an attribute declaration
60
61 procedure Parse_Case_Construction
62 (In_Tree : Project_Node_Tree_Ref;
63 Case_Construction : out Project_Node_Id;
64 First_Attribute : Attribute_Node_Id;
65 Current_Project : Project_Node_Id;
66 Current_Package : Project_Node_Id;
67 Packages_To_Check : String_List_Access;
68 Is_Config_File : Boolean;
69 Flags : Processing_Flags);
70 -- Parse a case construction
71
72 procedure Parse_Declarative_Items
73 (In_Tree : Project_Node_Tree_Ref;
74 Declarations : out Project_Node_Id;
75 In_Zone : Zone;
76 First_Attribute : Attribute_Node_Id;
77 Current_Project : Project_Node_Id;
78 Current_Package : Project_Node_Id;
79 Packages_To_Check : String_List_Access;
80 Is_Config_File : Boolean;
81 Flags : Processing_Flags);
82 -- Parse declarative items. Depending on In_Zone, some declarative items
83 -- may be forbidden. Is_Config_File should be set to True if the project
84 -- represents a config file (.cgpr) since some specific checks apply.
85
86 procedure Parse_Package_Declaration
87 (In_Tree : Project_Node_Tree_Ref;
88 Package_Declaration : out Project_Node_Id;
89 Current_Project : Project_Node_Id;
90 Packages_To_Check : String_List_Access;
91 Is_Config_File : Boolean;
92 Flags : Processing_Flags);
93 -- Parse a package declaration.
94 -- Is_Config_File should be set to True if the project represents a config
95 -- file (.cgpr) since some specific checks apply.
96
97 procedure Parse_String_Type_Declaration
98 (In_Tree : Project_Node_Tree_Ref;
99 String_Type : out Project_Node_Id;
100 Current_Project : Project_Node_Id;
101 Flags : Processing_Flags);
102 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
103
104 procedure Parse_Variable_Declaration
105 (In_Tree : Project_Node_Tree_Ref;
106 Variable : out Project_Node_Id;
107 Current_Project : Project_Node_Id;
108 Current_Package : Project_Node_Id;
109 Flags : Processing_Flags);
110 -- Parse a variable assignment
111 -- <variable_Name> := <expression>; OR
112 -- <variable_Name> : <string_type_Name> := <string_expression>;
113
114 -----------
115 -- Parse --
116 -----------
117
118 procedure Parse
119 (In_Tree : Project_Node_Tree_Ref;
120 Declarations : out Project_Node_Id;
121 Current_Project : Project_Node_Id;
122 Extends : Project_Node_Id;
123 Packages_To_Check : String_List_Access;
124 Is_Config_File : Boolean;
125 Flags : Processing_Flags)
126 is
127 First_Declarative_Item : Project_Node_Id := Empty_Node;
128
129 begin
130 Declarations :=
131 Default_Project_Node
132 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
133 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
134 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
135 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
136 Parse_Declarative_Items
137 (Declarations => First_Declarative_Item,
138 In_Tree => In_Tree,
139 In_Zone => In_Project,
140 First_Attribute => Prj.Attr.Attribute_First,
141 Current_Project => Current_Project,
142 Current_Package => Empty_Node,
143 Packages_To_Check => Packages_To_Check,
144 Is_Config_File => Is_Config_File,
145 Flags => Flags);
146 Set_First_Declarative_Item_Of
147 (Declarations, In_Tree, To => First_Declarative_Item);
148 end Parse;
149
150 ---------------------------------
151 -- Parse_Attribute_Declaration --
152 ---------------------------------
153
154 procedure Parse_Attribute_Declaration
155 (In_Tree : Project_Node_Tree_Ref;
156 Attribute : out Project_Node_Id;
157 First_Attribute : Attribute_Node_Id;
158 Current_Project : Project_Node_Id;
159 Current_Package : Project_Node_Id;
160 Packages_To_Check : String_List_Access;
161 Flags : Processing_Flags)
162 is
163 Current_Attribute : Attribute_Node_Id := First_Attribute;
164 Full_Associative_Array : Boolean := False;
165 Attribute_Name : Name_Id := No_Name;
166 Optional_Index : Boolean := False;
167 Pkg_Id : Package_Node_Id := Empty_Package;
168 Ignore : Boolean := False;
169
170 begin
171 Attribute :=
172 Default_Project_Node
173 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
174 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
175 Set_Previous_Line_Node (Attribute);
176
177 -- Scan past "for"
178
179 Scan (In_Tree);
180
181 -- Body may be an attribute name
182
183 if Token = Tok_Body then
184 Token := Tok_Identifier;
185 Token_Name := Snames.Name_Body;
186 end if;
187
188 Expect (Tok_Identifier, "identifier");
189
190 if Token = Tok_Identifier then
191 Attribute_Name := Token_Name;
192 Set_Name_Of (Attribute, In_Tree, To => Token_Name);
193 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
194
195 -- Find the attribute
196
197 Current_Attribute :=
198 Attribute_Node_Id_Of (Token_Name, First_Attribute);
199
200 -- If the attribute cannot be found, create the attribute if inside
201 -- an unknown package.
202
203 if Current_Attribute = Empty_Attribute then
204 if Present (Current_Package)
205 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
206 then
207 Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
208 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
209
210 else
211 -- If not a valid attribute name, issue an error if inside
212 -- a package that need to be checked.
213
214 Ignore := Present (Current_Package) and then
215 Packages_To_Check /= All_Packages;
216
217 if Ignore then
218
219 -- Check that we are not in a package to check
220
221 Get_Name_String (Name_Of (Current_Package, In_Tree));
222
223 for Index in Packages_To_Check'Range loop
224 if Name_Buffer (1 .. Name_Len) =
225 Packages_To_Check (Index).all
226 then
227 Ignore := False;
228 exit;
229 end if;
230 end loop;
231 end if;
232
233 if not Ignore then
234 Error_Msg_Name_1 := Token_Name;
235 Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
236 end if;
237 end if;
238
239 -- Set, if appropriate the index case insensitivity flag
240
241 else
242 if Is_Read_Only (Current_Attribute) then
243 Error_Msg_Name_1 := Token_Name;
244 Error_Msg
245 (Flags, "read-only attribute %% cannot be given a value",
246 Token_Ptr);
247 end if;
248
249 if Attribute_Kind_Of (Current_Attribute) in
250 Case_Insensitive_Associative_Array ..
251 Optional_Index_Case_Insensitive_Associative_Array
252 then
253 Set_Case_Insensitive (Attribute, In_Tree, To => True);
254 end if;
255 end if;
256
257 Scan (In_Tree); -- past the attribute name
258 end if;
259
260 -- Change obsolete names of attributes to the new names
261
262 if Present (Current_Package)
263 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
264 then
265 case Name_Of (Attribute, In_Tree) is
266 when Snames.Name_Specification =>
267 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
268
269 when Snames.Name_Specification_Suffix =>
270 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
271
272 when Snames.Name_Implementation =>
273 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
274
275 when Snames.Name_Implementation_Suffix =>
276 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
277
278 when others =>
279 null;
280 end case;
281 end if;
282
283 -- Associative array attributes
284
285 if Token = Tok_Left_Paren then
286
287 -- If the attribute is not an associative array attribute, report
288 -- an error. If this information is still unknown, set the kind
289 -- to Associative_Array.
290
291 if Current_Attribute /= Empty_Attribute
292 and then Attribute_Kind_Of (Current_Attribute) = Single
293 then
294 Error_Msg (Flags,
295 "the attribute """ &
296 Get_Name_String
297 (Attribute_Name_Of (Current_Attribute)) &
298 """ cannot be an associative array",
299 Location_Of (Attribute, In_Tree));
300
301 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
302 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
303 end if;
304
305 Scan (In_Tree); -- past the left parenthesis
306
307 if Others_Allowed_For (Current_Attribute)
308 and then Token = Tok_Others
309 then
310 Set_Associative_Array_Index_Of
311 (Attribute, In_Tree, All_Other_Names);
312 Scan (In_Tree); -- past others
313
314 else
315 if Others_Allowed_For (Current_Attribute) then
316 Expect (Tok_String_Literal, "literal string or others");
317 else
318 Expect (Tok_String_Literal, "literal string");
319 end if;
320
321 if Token = Tok_String_Literal then
322 Get_Name_String (Token_Name);
323
324 if Case_Insensitive (Attribute, In_Tree) then
325 To_Lower (Name_Buffer (1 .. Name_Len));
326 end if;
327
328 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
329 Scan (In_Tree); -- past the literal string index
330
331 if Token = Tok_At then
332 case Attribute_Kind_Of (Current_Attribute) is
333 when Optional_Index_Associative_Array |
334 Optional_Index_Case_Insensitive_Associative_Array =>
335 Scan (In_Tree);
336 Expect (Tok_Integer_Literal, "integer literal");
337
338 if Token = Tok_Integer_Literal then
339
340 -- Set the source index value from given literal
341
342 declare
343 Index : constant Int :=
344 UI_To_Int (Int_Literal_Value);
345 begin
346 if Index = 0 then
347 Error_Msg
348 (Flags, "index cannot be zero", Token_Ptr);
349 else
350 Set_Source_Index_Of
351 (Attribute, In_Tree, To => Index);
352 end if;
353 end;
354
355 Scan (In_Tree);
356 end if;
357
358 when others =>
359 Error_Msg (Flags, "index not allowed here", Token_Ptr);
360 Scan (In_Tree);
361
362 if Token = Tok_Integer_Literal then
363 Scan (In_Tree);
364 end if;
365 end case;
366 end if;
367 end if;
368 end if;
369
370 Expect (Tok_Right_Paren, "`)`");
371
372 if Token = Tok_Right_Paren then
373 Scan (In_Tree); -- past the right parenthesis
374 end if;
375
376 else
377 -- If it is an associative array attribute and there are no left
378 -- parenthesis, then this is a full associative array declaration.
379 -- Flag it as such for later processing of its value.
380
381 if Current_Attribute /= Empty_Attribute
382 and then
383 Attribute_Kind_Of (Current_Attribute) /= Single
384 then
385 if Attribute_Kind_Of (Current_Attribute) = Unknown then
386 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
387
388 else
389 Full_Associative_Array := True;
390 end if;
391 end if;
392 end if;
393
394 -- Set the expression kind of the attribute
395
396 if Current_Attribute /= Empty_Attribute then
397 Set_Expression_Kind_Of
398 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
399 Optional_Index := Optional_Index_Of (Current_Attribute);
400 end if;
401
402 Expect (Tok_Use, "USE");
403
404 if Token = Tok_Use then
405 Scan (In_Tree);
406
407 if Full_Associative_Array then
408
409 -- Expect <project>'<same_attribute_name>, or
410 -- <project>.<same_package_name>'<same_attribute_name>
411
412 declare
413 The_Project : Project_Node_Id := Empty_Node;
414 -- The node of the project where the associative array is
415 -- declared.
416
417 The_Package : Project_Node_Id := Empty_Node;
418 -- The node of the package where the associative array is
419 -- declared, if any.
420
421 Project_Name : Name_Id := No_Name;
422 -- The name of the project where the associative array is
423 -- declared.
424
425 Location : Source_Ptr := No_Location;
426 -- The location of the project name
427
428 begin
429 Expect (Tok_Identifier, "identifier");
430
431 if Token = Tok_Identifier then
432 Location := Token_Ptr;
433
434 -- Find the project node in the imported project or
435 -- in the project being extended.
436
437 The_Project := Imported_Or_Extended_Project_Of
438 (Current_Project, In_Tree, Token_Name);
439
440 if No (The_Project) then
441 Error_Msg (Flags, "unknown project", Location);
442 Scan (In_Tree); -- past the project name
443
444 else
445 Project_Name := Token_Name;
446 Scan (In_Tree); -- past the project name
447
448 -- If this is inside a package, a dot followed by the
449 -- name of the package must followed the project name.
450
451 if Present (Current_Package) then
452 Expect (Tok_Dot, "`.`");
453
454 if Token /= Tok_Dot then
455 The_Project := Empty_Node;
456
457 else
458 Scan (In_Tree); -- past the dot
459 Expect (Tok_Identifier, "identifier");
460
461 if Token /= Tok_Identifier then
462 The_Project := Empty_Node;
463
464 -- If it is not the same package name, issue error
465
466 elsif
467 Token_Name /= Name_Of (Current_Package, In_Tree)
468 then
469 The_Project := Empty_Node;
470 Error_Msg
471 (Flags, "not the same package as " &
472 Get_Name_String
473 (Name_Of (Current_Package, In_Tree)),
474 Token_Ptr);
475
476 else
477 The_Package :=
478 First_Package_Of (The_Project, In_Tree);
479
480 -- Look for the package node
481
482 while Present (The_Package)
483 and then
484 Name_Of (The_Package, In_Tree) /= Token_Name
485 loop
486 The_Package :=
487 Next_Package_In_Project
488 (The_Package, In_Tree);
489 end loop;
490
491 -- If the package cannot be found in the
492 -- project, issue an error.
493
494 if No (The_Package) then
495 The_Project := Empty_Node;
496 Error_Msg_Name_2 := Project_Name;
497 Error_Msg_Name_1 := Token_Name;
498 Error_Msg
499 (Flags,
500 "package % not declared in project %",
501 Token_Ptr);
502 end if;
503
504 Scan (In_Tree); -- past the package name
505 end if;
506 end if;
507 end if;
508 end if;
509 end if;
510
511 if Present (The_Project) then
512
513 -- Looking for '<same attribute name>
514
515 Expect (Tok_Apostrophe, "`''`");
516
517 if Token /= Tok_Apostrophe then
518 The_Project := Empty_Node;
519
520 else
521 Scan (In_Tree); -- past the apostrophe
522 Expect (Tok_Identifier, "identifier");
523
524 if Token /= Tok_Identifier then
525 The_Project := Empty_Node;
526
527 else
528 -- If it is not the same attribute name, issue error
529
530 if Token_Name /= Attribute_Name then
531 The_Project := Empty_Node;
532 Error_Msg_Name_1 := Attribute_Name;
533 Error_Msg
534 (Flags, "invalid name, should be %", Token_Ptr);
535 end if;
536
537 Scan (In_Tree); -- past the attribute name
538 end if;
539 end if;
540 end if;
541
542 if No (The_Project) then
543
544 -- If there were any problem, set the attribute id to null,
545 -- so that the node will not be recorded.
546
547 Current_Attribute := Empty_Attribute;
548
549 else
550 -- Set the appropriate field in the node.
551 -- Note that the index and the expression are nil. This
552 -- characterizes full associative array attribute
553 -- declarations.
554
555 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
556 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
557 end if;
558 end;
559
560 -- Other attribute declarations (not full associative array)
561
562 else
563 declare
564 Expression_Location : constant Source_Ptr := Token_Ptr;
565 -- The location of the first token of the expression
566
567 Expression : Project_Node_Id := Empty_Node;
568 -- The expression, value for the attribute declaration
569
570 begin
571 -- Get the expression value and set it in the attribute node
572
573 Parse_Expression
574 (In_Tree => In_Tree,
575 Expression => Expression,
576 Flags => Flags,
577 Current_Project => Current_Project,
578 Current_Package => Current_Package,
579 Optional_Index => Optional_Index);
580 Set_Expression_Of (Attribute, In_Tree, To => Expression);
581
582 -- If the expression is legal, but not of the right kind
583 -- for the attribute, issue an error.
584
585 if Current_Attribute /= Empty_Attribute
586 and then Present (Expression)
587 and then Variable_Kind_Of (Current_Attribute) /=
588 Expression_Kind_Of (Expression, In_Tree)
589 then
590 if Variable_Kind_Of (Current_Attribute) = Undefined then
591 Set_Variable_Kind_Of
592 (Current_Attribute,
593 To => Expression_Kind_Of (Expression, In_Tree));
594
595 else
596 Error_Msg
597 (Flags, "wrong expression kind for attribute """ &
598 Get_Name_String
599 (Attribute_Name_Of (Current_Attribute)) &
600 """",
601 Expression_Location);
602 end if;
603 end if;
604 end;
605 end if;
606 end if;
607
608 -- If the attribute was not recognized, return an empty node.
609 -- It may be that it is not in a package to check, and the node will
610 -- not be added to the tree.
611
612 if Current_Attribute = Empty_Attribute then
613 Attribute := Empty_Node;
614 end if;
615
616 Set_End_Of_Line (Attribute);
617 Set_Previous_Line_Node (Attribute);
618 end Parse_Attribute_Declaration;
619
620 -----------------------------
621 -- Parse_Case_Construction --
622 -----------------------------
623
624 procedure Parse_Case_Construction
625 (In_Tree : Project_Node_Tree_Ref;
626 Case_Construction : out Project_Node_Id;
627 First_Attribute : Attribute_Node_Id;
628 Current_Project : Project_Node_Id;
629 Current_Package : Project_Node_Id;
630 Packages_To_Check : String_List_Access;
631 Is_Config_File : Boolean;
632 Flags : Processing_Flags)
633 is
634 Current_Item : Project_Node_Id := Empty_Node;
635 Next_Item : Project_Node_Id := Empty_Node;
636 First_Case_Item : Boolean := True;
637
638 Variable_Location : Source_Ptr := No_Location;
639
640 String_Type : Project_Node_Id := Empty_Node;
641
642 Case_Variable : Project_Node_Id := Empty_Node;
643
644 First_Declarative_Item : Project_Node_Id := Empty_Node;
645
646 First_Choice : Project_Node_Id := Empty_Node;
647
648 When_Others : Boolean := False;
649 -- Set to True when there is a "when others =>" clause
650
651 begin
652 Case_Construction :=
653 Default_Project_Node
654 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
655 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
656
657 -- Scan past "case"
658
659 Scan (In_Tree);
660
661 -- Get the switch variable
662
663 Expect (Tok_Identifier, "identifier");
664
665 if Token = Tok_Identifier then
666 Variable_Location := Token_Ptr;
667 Parse_Variable_Reference
668 (In_Tree => In_Tree,
669 Variable => Case_Variable,
670 Flags => Flags,
671 Current_Project => Current_Project,
672 Current_Package => Current_Package);
673 Set_Case_Variable_Reference_Of
674 (Case_Construction, In_Tree, To => Case_Variable);
675
676 else
677 if Token /= Tok_Is then
678 Scan (In_Tree);
679 end if;
680 end if;
681
682 if Present (Case_Variable) then
683 String_Type := String_Type_Of (Case_Variable, In_Tree);
684
685 if No (String_Type) then
686 Error_Msg (Flags,
687 "variable """ &
688 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
689 """ is not typed",
690 Variable_Location);
691 end if;
692 end if;
693
694 Expect (Tok_Is, "IS");
695
696 if Token = Tok_Is then
697 Set_End_Of_Line (Case_Construction);
698 Set_Previous_Line_Node (Case_Construction);
699 Set_Next_End_Node (Case_Construction);
700
701 -- Scan past "is"
702
703 Scan (In_Tree);
704 end if;
705
706 Start_New_Case_Construction (In_Tree, String_Type);
707
708 When_Loop :
709
710 while Token = Tok_When loop
711
712 if First_Case_Item then
713 Current_Item :=
714 Default_Project_Node
715 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
716 Set_First_Case_Item_Of
717 (Case_Construction, In_Tree, To => Current_Item);
718 First_Case_Item := False;
719
720 else
721 Next_Item :=
722 Default_Project_Node
723 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
724 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
725 Current_Item := Next_Item;
726 end if;
727
728 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
729
730 -- Scan past "when"
731
732 Scan (In_Tree);
733
734 if Token = Tok_Others then
735 When_Others := True;
736
737 -- Scan past "others"
738
739 Scan (In_Tree);
740
741 Expect (Tok_Arrow, "`=>`");
742 Set_End_Of_Line (Current_Item);
743 Set_Previous_Line_Node (Current_Item);
744
745 -- Empty_Node in Field1 of a Case_Item indicates
746 -- the "when others =>" branch.
747
748 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
749
750 Parse_Declarative_Items
751 (In_Tree => In_Tree,
752 Declarations => First_Declarative_Item,
753 In_Zone => In_Case_Construction,
754 First_Attribute => First_Attribute,
755 Current_Project => Current_Project,
756 Current_Package => Current_Package,
757 Packages_To_Check => Packages_To_Check,
758 Is_Config_File => Is_Config_File,
759 Flags => Flags);
760
761 -- "when others =>" must be the last branch, so save the
762 -- Case_Item and exit
763
764 Set_First_Declarative_Item_Of
765 (Current_Item, In_Tree, To => First_Declarative_Item);
766 exit When_Loop;
767
768 else
769 Parse_Choice_List
770 (In_Tree => In_Tree,
771 First_Choice => First_Choice,
772 Flags => Flags);
773 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
774
775 Expect (Tok_Arrow, "`=>`");
776 Set_End_Of_Line (Current_Item);
777 Set_Previous_Line_Node (Current_Item);
778
779 Parse_Declarative_Items
780 (In_Tree => In_Tree,
781 Declarations => First_Declarative_Item,
782 In_Zone => In_Case_Construction,
783 First_Attribute => First_Attribute,
784 Current_Project => Current_Project,
785 Current_Package => Current_Package,
786 Packages_To_Check => Packages_To_Check,
787 Is_Config_File => Is_Config_File,
788 Flags => Flags);
789
790 Set_First_Declarative_Item_Of
791 (Current_Item, In_Tree, To => First_Declarative_Item);
792
793 end if;
794 end loop When_Loop;
795
796 End_Case_Construction
797 (Check_All_Labels => not When_Others and not Quiet_Output,
798 Case_Location => Location_Of (Case_Construction, In_Tree),
799 Flags => Flags);
800
801 Expect (Tok_End, "`END CASE`");
802 Remove_Next_End_Node;
803
804 if Token = Tok_End then
805
806 -- Scan past "end"
807
808 Scan (In_Tree);
809
810 Expect (Tok_Case, "CASE");
811
812 end if;
813
814 -- Scan past "case"
815
816 Scan (In_Tree);
817
818 Expect (Tok_Semicolon, "`;`");
819 Set_Previous_End_Node (Case_Construction);
820
821 end Parse_Case_Construction;
822
823 -----------------------------
824 -- Parse_Declarative_Items --
825 -----------------------------
826
827 procedure Parse_Declarative_Items
828 (In_Tree : Project_Node_Tree_Ref;
829 Declarations : out Project_Node_Id;
830 In_Zone : Zone;
831 First_Attribute : Attribute_Node_Id;
832 Current_Project : Project_Node_Id;
833 Current_Package : Project_Node_Id;
834 Packages_To_Check : String_List_Access;
835 Is_Config_File : Boolean;
836 Flags : Processing_Flags)
837 is
838 Current_Declarative_Item : Project_Node_Id := Empty_Node;
839 Next_Declarative_Item : Project_Node_Id := Empty_Node;
840 Current_Declaration : Project_Node_Id := Empty_Node;
841 Item_Location : Source_Ptr := No_Location;
842
843 begin
844 Declarations := Empty_Node;
845
846 loop
847 -- We are always positioned at the token that precedes the first
848 -- token of the declarative element. Scan past it.
849
850 Scan (In_Tree);
851
852 Item_Location := Token_Ptr;
853
854 case Token is
855 when Tok_Identifier =>
856
857 if In_Zone = In_Case_Construction then
858
859 -- Check if the variable has already been declared
860
861 declare
862 The_Variable : Project_Node_Id := Empty_Node;
863
864 begin
865 if Present (Current_Package) then
866 The_Variable :=
867 First_Variable_Of (Current_Package, In_Tree);
868 elsif Present (Current_Project) then
869 The_Variable :=
870 First_Variable_Of (Current_Project, In_Tree);
871 end if;
872
873 while Present (The_Variable)
874 and then Name_Of (The_Variable, In_Tree) /=
875 Token_Name
876 loop
877 The_Variable := Next_Variable (The_Variable, In_Tree);
878 end loop;
879
880 -- It is an error to declare a variable in a case
881 -- construction for the first time.
882
883 if No (The_Variable) then
884 Error_Msg
885 (Flags,
886 "a variable cannot be declared " &
887 "for the first time here",
888 Token_Ptr);
889 end if;
890 end;
891 end if;
892
893 Parse_Variable_Declaration
894 (In_Tree,
895 Current_Declaration,
896 Current_Project => Current_Project,
897 Current_Package => Current_Package,
898 Flags => Flags);
899
900 Set_End_Of_Line (Current_Declaration);
901 Set_Previous_Line_Node (Current_Declaration);
902
903 when Tok_For =>
904
905 Parse_Attribute_Declaration
906 (In_Tree => In_Tree,
907 Attribute => Current_Declaration,
908 First_Attribute => First_Attribute,
909 Current_Project => Current_Project,
910 Current_Package => Current_Package,
911 Packages_To_Check => Packages_To_Check,
912 Flags => Flags);
913
914 Set_End_Of_Line (Current_Declaration);
915 Set_Previous_Line_Node (Current_Declaration);
916
917 when Tok_Null =>
918
919 Scan (In_Tree); -- past "null"
920
921 when Tok_Package =>
922
923 -- Package declaration
924
925 if In_Zone /= In_Project then
926 Error_Msg
927 (Flags, "a package cannot be declared here", Token_Ptr);
928 end if;
929
930 Parse_Package_Declaration
931 (In_Tree => In_Tree,
932 Package_Declaration => Current_Declaration,
933 Current_Project => Current_Project,
934 Packages_To_Check => Packages_To_Check,
935 Is_Config_File => Is_Config_File,
936 Flags => Flags);
937
938 Set_Previous_End_Node (Current_Declaration);
939
940 when Tok_Type =>
941
942 -- Type String Declaration
943
944 if In_Zone /= In_Project then
945 Error_Msg (Flags,
946 "a string type cannot be declared here",
947 Token_Ptr);
948 end if;
949
950 Parse_String_Type_Declaration
951 (In_Tree => In_Tree,
952 String_Type => Current_Declaration,
953 Current_Project => Current_Project,
954 Flags => Flags);
955
956 Set_End_Of_Line (Current_Declaration);
957 Set_Previous_Line_Node (Current_Declaration);
958
959 when Tok_Case =>
960
961 -- Case construction
962
963 Parse_Case_Construction
964 (In_Tree => In_Tree,
965 Case_Construction => Current_Declaration,
966 First_Attribute => First_Attribute,
967 Current_Project => Current_Project,
968 Current_Package => Current_Package,
969 Packages_To_Check => Packages_To_Check,
970 Is_Config_File => Is_Config_File,
971 Flags => Flags);
972
973 Set_Previous_End_Node (Current_Declaration);
974
975 when others =>
976 exit;
977
978 -- We are leaving Parse_Declarative_Items positioned
979 -- at the first token after the list of declarative items.
980 -- It could be "end" (for a project, a package declaration or
981 -- a case construction) or "when" (for a case construction)
982
983 end case;
984
985 Expect (Tok_Semicolon, "`;` after declarative items");
986
987 -- Insert an N_Declarative_Item in the tree, but only if
988 -- Current_Declaration is not an empty node.
989
990 if Present (Current_Declaration) then
991 if No (Current_Declarative_Item) then
992 Current_Declarative_Item :=
993 Default_Project_Node
994 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
995 Declarations := Current_Declarative_Item;
996
997 else
998 Next_Declarative_Item :=
999 Default_Project_Node
1000 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1001 Set_Next_Declarative_Item
1002 (Current_Declarative_Item, In_Tree,
1003 To => Next_Declarative_Item);
1004 Current_Declarative_Item := Next_Declarative_Item;
1005 end if;
1006
1007 Set_Current_Item_Node
1008 (Current_Declarative_Item, In_Tree,
1009 To => Current_Declaration);
1010 Set_Location_Of
1011 (Current_Declarative_Item, In_Tree, To => Item_Location);
1012 end if;
1013 end loop;
1014 end Parse_Declarative_Items;
1015
1016 -------------------------------
1017 -- Parse_Package_Declaration --
1018 -------------------------------
1019
1020 procedure Parse_Package_Declaration
1021 (In_Tree : Project_Node_Tree_Ref;
1022 Package_Declaration : out Project_Node_Id;
1023 Current_Project : Project_Node_Id;
1024 Packages_To_Check : String_List_Access;
1025 Is_Config_File : Boolean;
1026 Flags : Processing_Flags)
1027 is
1028 First_Attribute : Attribute_Node_Id := Empty_Attribute;
1029 Current_Package : Package_Node_Id := Empty_Package;
1030 First_Declarative_Item : Project_Node_Id := Empty_Node;
1031
1032 Package_Location : constant Source_Ptr := Token_Ptr;
1033
1034 begin
1035 Package_Declaration :=
1036 Default_Project_Node
1037 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
1038 Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
1039
1040 -- Scan past "package"
1041
1042 Scan (In_Tree);
1043 Expect (Tok_Identifier, "identifier");
1044
1045 if Token = Tok_Identifier then
1046 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
1047
1048 Current_Package := Package_Node_Id_Of (Token_Name);
1049
1050 if Current_Package = Empty_Package then
1051 if not Quiet_Output then
1052 declare
1053 List : constant Strings.String_List := Package_Name_List;
1054 Index : Natural;
1055 Name : constant String := Get_Name_String (Token_Name);
1056
1057 begin
1058 -- Check for possible misspelling of a known package name
1059
1060 Index := 0;
1061 loop
1062 if Index >= List'Last then
1063 Index := 0;
1064 exit;
1065 end if;
1066
1067 Index := Index + 1;
1068 exit when
1069 GNAT.Spelling_Checker.Is_Bad_Spelling_Of
1070 (Name, List (Index).all);
1071 end loop;
1072
1073 -- Issue warning(s) in verbose mode or when a possible
1074 -- misspelling has been found.
1075
1076 if Verbose_Mode or else Index /= 0 then
1077 Error_Msg (Flags,
1078 "?""" &
1079 Get_Name_String
1080 (Name_Of (Package_Declaration, In_Tree)) &
1081 """ is not a known package name",
1082 Token_Ptr);
1083 end if;
1084
1085 if Index /= 0 then
1086 Error_Msg -- CODEFIX
1087 (Flags,
1088 "\?possible misspelling of """ &
1089 List (Index).all & """", Token_Ptr);
1090 end if;
1091 end;
1092 end if;
1093
1094 -- Set the package declaration to "ignored" so that it is not
1095 -- processed by Prj.Proc.Process.
1096
1097 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1098
1099 -- Add the unknown package in the list of packages
1100
1101 Add_Unknown_Package (Token_Name, Current_Package);
1102
1103 elsif Current_Package = Unknown_Package then
1104
1105 -- Set the package declaration to "ignored" so that it is not
1106 -- processed by Prj.Proc.Process.
1107
1108 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1109
1110 else
1111 First_Attribute := First_Attribute_Of (Current_Package);
1112 end if;
1113
1114 Set_Package_Id_Of
1115 (Package_Declaration, In_Tree, To => Current_Package);
1116
1117 declare
1118 Current : Project_Node_Id :=
1119 First_Package_Of (Current_Project, In_Tree);
1120
1121 begin
1122 while Present (Current)
1123 and then Name_Of (Current, In_Tree) /= Token_Name
1124 loop
1125 Current := Next_Package_In_Project (Current, In_Tree);
1126 end loop;
1127
1128 if Present (Current) then
1129 Error_Msg
1130 (Flags,
1131 "package """ &
1132 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
1133 """ is declared twice in the same project",
1134 Token_Ptr);
1135
1136 else
1137 -- Add the package to the project list
1138
1139 Set_Next_Package_In_Project
1140 (Package_Declaration, In_Tree,
1141 To => First_Package_Of (Current_Project, In_Tree));
1142 Set_First_Package_Of
1143 (Current_Project, In_Tree, To => Package_Declaration);
1144 end if;
1145 end;
1146
1147 -- Scan past the package name
1148
1149 Scan (In_Tree);
1150 end if;
1151
1152 if Token = Tok_Renames then
1153 if Is_Config_File then
1154 Error_Msg
1155 (Flags,
1156 "no package renames in configuration projects", Token_Ptr);
1157 end if;
1158
1159 -- Scan past "renames"
1160
1161 Scan (In_Tree);
1162
1163 Expect (Tok_Identifier, "identifier");
1164
1165 if Token = Tok_Identifier then
1166 declare
1167 Project_Name : constant Name_Id := Token_Name;
1168
1169 Clause : Project_Node_Id :=
1170 First_With_Clause_Of (Current_Project, In_Tree);
1171 The_Project : Project_Node_Id := Empty_Node;
1172 Extended : constant Project_Node_Id :=
1173 Extended_Project_Of
1174 (Project_Declaration_Of
1175 (Current_Project, In_Tree),
1176 In_Tree);
1177 begin
1178 while Present (Clause) loop
1179 -- Only non limited imported projects may be used in a
1180 -- renames declaration.
1181
1182 The_Project :=
1183 Non_Limited_Project_Node_Of (Clause, In_Tree);
1184 exit when Present (The_Project)
1185 and then Name_Of (The_Project, In_Tree) = Project_Name;
1186 Clause := Next_With_Clause_Of (Clause, In_Tree);
1187 end loop;
1188
1189 if No (Clause) then
1190 -- As we have not found the project in the imports, we check
1191 -- if it's the name of an eventual extended project.
1192
1193 if Present (Extended)
1194 and then Name_Of (Extended, In_Tree) = Project_Name
1195 then
1196 Set_Project_Of_Renamed_Package_Of
1197 (Package_Declaration, In_Tree, To => Extended);
1198 else
1199 Error_Msg_Name_1 := Project_Name;
1200 Error_Msg
1201 (Flags,
1202 "% is not an imported or extended project", Token_Ptr);
1203 end if;
1204 else
1205 Set_Project_Of_Renamed_Package_Of
1206 (Package_Declaration, In_Tree, To => The_Project);
1207 end if;
1208 end;
1209
1210 Scan (In_Tree);
1211 Expect (Tok_Dot, "`.`");
1212
1213 if Token = Tok_Dot then
1214 Scan (In_Tree);
1215 Expect (Tok_Identifier, "identifier");
1216
1217 if Token = Tok_Identifier then
1218 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1219 Error_Msg (Flags, "not the same package name", Token_Ptr);
1220 elsif
1221 Present (Project_Of_Renamed_Package_Of
1222 (Package_Declaration, In_Tree))
1223 then
1224 declare
1225 Current : Project_Node_Id :=
1226 First_Package_Of
1227 (Project_Of_Renamed_Package_Of
1228 (Package_Declaration, In_Tree),
1229 In_Tree);
1230
1231 begin
1232 while Present (Current)
1233 and then Name_Of (Current, In_Tree) /= Token_Name
1234 loop
1235 Current :=
1236 Next_Package_In_Project (Current, In_Tree);
1237 end loop;
1238
1239 if No (Current) then
1240 Error_Msg
1241 (Flags, """" &
1242 Get_Name_String (Token_Name) &
1243 """ is not a package declared by the project",
1244 Token_Ptr);
1245 end if;
1246 end;
1247 end if;
1248
1249 Scan (In_Tree);
1250 end if;
1251 end if;
1252 end if;
1253
1254 Expect (Tok_Semicolon, "`;`");
1255 Set_End_Of_Line (Package_Declaration);
1256 Set_Previous_Line_Node (Package_Declaration);
1257
1258 elsif Token = Tok_Is then
1259 Set_End_Of_Line (Package_Declaration);
1260 Set_Previous_Line_Node (Package_Declaration);
1261 Set_Next_End_Node (Package_Declaration);
1262
1263 Parse_Declarative_Items
1264 (In_Tree => In_Tree,
1265 Declarations => First_Declarative_Item,
1266 In_Zone => In_Package,
1267 First_Attribute => First_Attribute,
1268 Current_Project => Current_Project,
1269 Current_Package => Package_Declaration,
1270 Packages_To_Check => Packages_To_Check,
1271 Is_Config_File => Is_Config_File,
1272 Flags => Flags);
1273
1274 Set_First_Declarative_Item_Of
1275 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1276
1277 Expect (Tok_End, "END");
1278
1279 if Token = Tok_End then
1280
1281 -- Scan past "end"
1282
1283 Scan (In_Tree);
1284 end if;
1285
1286 -- We should have the name of the package after "end"
1287
1288 Expect (Tok_Identifier, "identifier");
1289
1290 if Token = Tok_Identifier
1291 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1292 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1293 then
1294 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1295 Error_Msg (Flags, "expected %%", Token_Ptr);
1296 end if;
1297
1298 if Token /= Tok_Semicolon then
1299
1300 -- Scan past the package name
1301
1302 Scan (In_Tree);
1303 end if;
1304
1305 Expect (Tok_Semicolon, "`;`");
1306 Remove_Next_End_Node;
1307
1308 else
1309 Error_Msg (Flags, "expected IS or RENAMES", Token_Ptr);
1310 end if;
1311
1312 end Parse_Package_Declaration;
1313
1314 -----------------------------------
1315 -- Parse_String_Type_Declaration --
1316 -----------------------------------
1317
1318 procedure Parse_String_Type_Declaration
1319 (In_Tree : Project_Node_Tree_Ref;
1320 String_Type : out Project_Node_Id;
1321 Current_Project : Project_Node_Id;
1322 Flags : Processing_Flags)
1323 is
1324 Current : Project_Node_Id := Empty_Node;
1325 First_String : Project_Node_Id := Empty_Node;
1326
1327 begin
1328 String_Type :=
1329 Default_Project_Node
1330 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1331
1332 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1333
1334 -- Scan past "type"
1335
1336 Scan (In_Tree);
1337
1338 Expect (Tok_Identifier, "identifier");
1339
1340 if Token = Tok_Identifier then
1341 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1342
1343 Current := First_String_Type_Of (Current_Project, In_Tree);
1344 while Present (Current)
1345 and then
1346 Name_Of (Current, In_Tree) /= Token_Name
1347 loop
1348 Current := Next_String_Type (Current, In_Tree);
1349 end loop;
1350
1351 if Present (Current) then
1352 Error_Msg (Flags,
1353 "duplicate string type name """ &
1354 Get_Name_String (Token_Name) &
1355 """",
1356 Token_Ptr);
1357 else
1358 Current := First_Variable_Of (Current_Project, In_Tree);
1359 while Present (Current)
1360 and then Name_Of (Current, In_Tree) /= Token_Name
1361 loop
1362 Current := Next_Variable (Current, In_Tree);
1363 end loop;
1364
1365 if Present (Current) then
1366 Error_Msg (Flags,
1367 """" &
1368 Get_Name_String (Token_Name) &
1369 """ is already a variable name", Token_Ptr);
1370 else
1371 Set_Next_String_Type
1372 (String_Type, In_Tree,
1373 To => First_String_Type_Of (Current_Project, In_Tree));
1374 Set_First_String_Type_Of
1375 (Current_Project, In_Tree, To => String_Type);
1376 end if;
1377 end if;
1378
1379 -- Scan past the name
1380
1381 Scan (In_Tree);
1382 end if;
1383
1384 Expect (Tok_Is, "IS");
1385
1386 if Token = Tok_Is then
1387 Scan (In_Tree);
1388 end if;
1389
1390 Expect (Tok_Left_Paren, "`(`");
1391
1392 if Token = Tok_Left_Paren then
1393 Scan (In_Tree);
1394 end if;
1395
1396 Parse_String_Type_List
1397 (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
1398 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1399
1400 Expect (Tok_Right_Paren, "`)`");
1401
1402 if Token = Tok_Right_Paren then
1403 Scan (In_Tree);
1404 end if;
1405
1406 end Parse_String_Type_Declaration;
1407
1408 --------------------------------
1409 -- Parse_Variable_Declaration --
1410 --------------------------------
1411
1412 procedure Parse_Variable_Declaration
1413 (In_Tree : Project_Node_Tree_Ref;
1414 Variable : out Project_Node_Id;
1415 Current_Project : Project_Node_Id;
1416 Current_Package : Project_Node_Id;
1417 Flags : Processing_Flags)
1418 is
1419 Expression_Location : Source_Ptr;
1420 String_Type_Name : Name_Id := No_Name;
1421 Project_String_Type_Name : Name_Id := No_Name;
1422 Type_Location : Source_Ptr := No_Location;
1423 Project_Location : Source_Ptr := No_Location;
1424 Expression : Project_Node_Id := Empty_Node;
1425 Variable_Name : constant Name_Id := Token_Name;
1426 OK : Boolean := True;
1427
1428 begin
1429 Variable :=
1430 Default_Project_Node
1431 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1432 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1433 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1434
1435 -- Scan past the variable name
1436
1437 Scan (In_Tree);
1438
1439 if Token = Tok_Colon then
1440
1441 -- Typed string variable declaration
1442
1443 Scan (In_Tree);
1444 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1445 Expect (Tok_Identifier, "identifier");
1446
1447 OK := Token = Tok_Identifier;
1448
1449 if OK then
1450 String_Type_Name := Token_Name;
1451 Type_Location := Token_Ptr;
1452 Scan (In_Tree);
1453
1454 if Token = Tok_Dot then
1455 Project_String_Type_Name := String_Type_Name;
1456 Project_Location := Type_Location;
1457
1458 -- Scan past the dot
1459
1460 Scan (In_Tree);
1461 Expect (Tok_Identifier, "identifier");
1462
1463 if Token = Tok_Identifier then
1464 String_Type_Name := Token_Name;
1465 Type_Location := Token_Ptr;
1466 Scan (In_Tree);
1467 else
1468 OK := False;
1469 end if;
1470 end if;
1471
1472 if OK then
1473 declare
1474 Proj : Project_Node_Id := Current_Project;
1475 Current : Project_Node_Id := Empty_Node;
1476
1477 begin
1478 if Project_String_Type_Name /= No_Name then
1479 declare
1480 The_Project_Name_And_Node : constant
1481 Tree_Private_Part.Project_Name_And_Node :=
1482 Tree_Private_Part.Projects_Htable.Get
1483 (In_Tree.Projects_HT, Project_String_Type_Name);
1484
1485 use Tree_Private_Part;
1486
1487 begin
1488 if The_Project_Name_And_Node =
1489 Tree_Private_Part.No_Project_Name_And_Node
1490 then
1491 Error_Msg (Flags,
1492 "unknown project """ &
1493 Get_Name_String
1494 (Project_String_Type_Name) &
1495 """",
1496 Project_Location);
1497 Current := Empty_Node;
1498 else
1499 Current :=
1500 First_String_Type_Of
1501 (The_Project_Name_And_Node.Node, In_Tree);
1502 while
1503 Present (Current)
1504 and then
1505 Name_Of (Current, In_Tree) /= String_Type_Name
1506 loop
1507 Current := Next_String_Type (Current, In_Tree);
1508 end loop;
1509 end if;
1510 end;
1511
1512 else
1513 -- Look for a string type with the correct name in this
1514 -- project or in any of its ancestors.
1515
1516 loop
1517 Current :=
1518 First_String_Type_Of (Proj, In_Tree);
1519 while
1520 Present (Current)
1521 and then
1522 Name_Of (Current, In_Tree) /= String_Type_Name
1523 loop
1524 Current := Next_String_Type (Current, In_Tree);
1525 end loop;
1526
1527 exit when Present (Current);
1528
1529 Proj := Parent_Project_Of (Proj, In_Tree);
1530 exit when No (Proj);
1531 end loop;
1532 end if;
1533
1534 if No (Current) then
1535 Error_Msg (Flags,
1536 "unknown string type """ &
1537 Get_Name_String (String_Type_Name) &
1538 """",
1539 Type_Location);
1540 OK := False;
1541
1542 else
1543 Set_String_Type_Of
1544 (Variable, In_Tree, To => Current);
1545 end if;
1546 end;
1547 end if;
1548 end if;
1549 end if;
1550
1551 Expect (Tok_Colon_Equal, "`:=`");
1552
1553 OK := OK and then Token = Tok_Colon_Equal;
1554
1555 if Token = Tok_Colon_Equal then
1556 Scan (In_Tree);
1557 end if;
1558
1559 -- Get the single string or string list value
1560
1561 Expression_Location := Token_Ptr;
1562
1563 Parse_Expression
1564 (In_Tree => In_Tree,
1565 Expression => Expression,
1566 Flags => Flags,
1567 Current_Project => Current_Project,
1568 Current_Package => Current_Package,
1569 Optional_Index => False);
1570 Set_Expression_Of (Variable, In_Tree, To => Expression);
1571
1572 if Present (Expression) then
1573 -- A typed string must have a single string value, not a list
1574
1575 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1576 and then Expression_Kind_Of (Expression, In_Tree) = List
1577 then
1578 Error_Msg
1579 (Flags,
1580 "expression must be a single string", Expression_Location);
1581 end if;
1582
1583 Set_Expression_Kind_Of
1584 (Variable, In_Tree,
1585 To => Expression_Kind_Of (Expression, In_Tree));
1586 end if;
1587
1588 if OK then
1589 declare
1590 The_Variable : Project_Node_Id := Empty_Node;
1591
1592 begin
1593 if Present (Current_Package) then
1594 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1595 elsif Present (Current_Project) then
1596 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1597 end if;
1598
1599 while Present (The_Variable)
1600 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1601 loop
1602 The_Variable := Next_Variable (The_Variable, In_Tree);
1603 end loop;
1604
1605 if No (The_Variable) then
1606 if Present (Current_Package) then
1607 Set_Next_Variable
1608 (Variable, In_Tree,
1609 To => First_Variable_Of (Current_Package, In_Tree));
1610 Set_First_Variable_Of
1611 (Current_Package, In_Tree, To => Variable);
1612
1613 elsif Present (Current_Project) then
1614 Set_Next_Variable
1615 (Variable, In_Tree,
1616 To => First_Variable_Of (Current_Project, In_Tree));
1617 Set_First_Variable_Of
1618 (Current_Project, In_Tree, To => Variable);
1619 end if;
1620
1621 else
1622 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1623 if Expression_Kind_Of (The_Variable, In_Tree) =
1624 Undefined
1625 then
1626 Set_Expression_Kind_Of
1627 (The_Variable, In_Tree,
1628 To => Expression_Kind_Of (Variable, In_Tree));
1629
1630 else
1631 if Expression_Kind_Of (The_Variable, In_Tree) /=
1632 Expression_Kind_Of (Variable, In_Tree)
1633 then
1634 Error_Msg (Flags,
1635 "wrong expression kind for variable """ &
1636 Get_Name_String
1637 (Name_Of (The_Variable, In_Tree)) &
1638 """",
1639 Expression_Location);
1640 end if;
1641 end if;
1642 end if;
1643 end if;
1644 end;
1645 end if;
1646 end Parse_Variable_Declaration;
1647
1648 end Prj.Dect;