?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
In gcc/testsuite/: 2010-09-30 Nicola Pero <nicola.pero@meta-innovation.com>
[official-gcc.git] / gcc / ada / prj-dect.adb
blob51332d89daebdcc273164dbde214aa28ffa0e3fa
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-2010, 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 All_Case_Insensitive_Associative_Array
251 then
252 Set_Case_Insensitive (Attribute, In_Tree, To => True);
253 end if;
254 end if;
255
256 Scan (In_Tree); -- past the attribute name
257 end if;
258
259 -- Change obsolete names of attributes to the new names
260
261 if Present (Current_Package)
262 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
263 then
264 case Name_Of (Attribute, In_Tree) is
265 when Snames.Name_Specification =>
266 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
267
268 when Snames.Name_Specification_Suffix =>
269 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
270
271 when Snames.Name_Implementation =>
272 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
273
274 when Snames.Name_Implementation_Suffix =>
275 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
276
277 when others =>
278 null;
279 end case;
280 end if;
281
282 -- Associative array attributes
283
284 if Token = Tok_Left_Paren then
285
286 -- If the attribute is not an associative array attribute, report
287 -- an error. If this information is still unknown, set the kind
288 -- to Associative_Array.
289
290 if Current_Attribute /= Empty_Attribute
291 and then Attribute_Kind_Of (Current_Attribute) = Single
292 then
293 Error_Msg (Flags,
294 "the attribute """ &
295 Get_Name_String
296 (Attribute_Name_Of (Current_Attribute)) &
297 """ cannot be an associative array",
298 Location_Of (Attribute, In_Tree));
299
300 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
301 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
302 end if;
303
304 Scan (In_Tree); -- past the left parenthesis
305
306 if Others_Allowed_For (Current_Attribute)
307 and then Token = Tok_Others
308 then
309 Set_Associative_Array_Index_Of
310 (Attribute, In_Tree, All_Other_Names);
311 Scan (In_Tree); -- past others
312
313 else
314 if Others_Allowed_For (Current_Attribute) then
315 Expect (Tok_String_Literal, "literal string or others");
316 else
317 Expect (Tok_String_Literal, "literal string");
318 end if;
319
320 if Token = Tok_String_Literal then
321 Get_Name_String (Token_Name);
322
323 if Case_Insensitive (Attribute, In_Tree) then
324 To_Lower (Name_Buffer (1 .. Name_Len));
325 end if;
326
327 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
328 Scan (In_Tree); -- past the literal string index
329
330 if Token = Tok_At then
331 case Attribute_Kind_Of (Current_Attribute) is
332 when Optional_Index_Associative_Array |
333 Optional_Index_Case_Insensitive_Associative_Array =>
334 Scan (In_Tree);
335 Expect (Tok_Integer_Literal, "integer literal");
336
337 if Token = Tok_Integer_Literal then
338
339 -- Set the source index value from given literal
340
341 declare
342 Index : constant Int :=
343 UI_To_Int (Int_Literal_Value);
344 begin
345 if Index = 0 then
346 Error_Msg
347 (Flags, "index cannot be zero", Token_Ptr);
348 else
349 Set_Source_Index_Of
350 (Attribute, In_Tree, To => Index);
351 end if;
352 end;
353
354 Scan (In_Tree);
355 end if;
356
357 when others =>
358 Error_Msg (Flags, "index not allowed here", Token_Ptr);
359 Scan (In_Tree);
360
361 if Token = Tok_Integer_Literal then
362 Scan (In_Tree);
363 end if;
364 end case;
365 end if;
366 end if;
367 end if;
368
369 Expect (Tok_Right_Paren, "`)`");
370
371 if Token = Tok_Right_Paren then
372 Scan (In_Tree); -- past the right parenthesis
373 end if;
374
375 else
376 -- If it is an associative array attribute and there are no left
377 -- parenthesis, then this is a full associative array declaration.
378 -- Flag it as such for later processing of its value.
379
380 if Current_Attribute /= Empty_Attribute
381 and then
382 Attribute_Kind_Of (Current_Attribute) /= Single
383 then
384 if Attribute_Kind_Of (Current_Attribute) = Unknown then
385 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
386
387 else
388 Full_Associative_Array := True;
389 end if;
390 end if;
391 end if;
392
393 -- Set the expression kind of the attribute
394
395 if Current_Attribute /= Empty_Attribute then
396 Set_Expression_Kind_Of
397 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
398 Optional_Index := Optional_Index_Of (Current_Attribute);
399 end if;
400
401 Expect (Tok_Use, "USE");
402
403 if Token = Tok_Use then
404 Scan (In_Tree);
405
406 if Full_Associative_Array then
407
408 -- Expect <project>'<same_attribute_name>, or
409 -- <project>.<same_package_name>'<same_attribute_name>
410
411 declare
412 The_Project : Project_Node_Id := Empty_Node;
413 -- The node of the project where the associative array is
414 -- declared.
415
416 The_Package : Project_Node_Id := Empty_Node;
417 -- The node of the package where the associative array is
418 -- declared, if any.
419
420 Project_Name : Name_Id := No_Name;
421 -- The name of the project where the associative array is
422 -- declared.
423
424 Location : Source_Ptr := No_Location;
425 -- The location of the project name
426
427 begin
428 Expect (Tok_Identifier, "identifier");
429
430 if Token = Tok_Identifier then
431 Location := Token_Ptr;
432
433 -- Find the project node in the imported project or
434 -- in the project being extended.
435
436 The_Project := Imported_Or_Extended_Project_Of
437 (Current_Project, In_Tree, Token_Name);
438
439 if No (The_Project) then
440 Error_Msg (Flags, "unknown project", Location);
441 Scan (In_Tree); -- past the project name
442
443 else
444 Project_Name := Token_Name;
445 Scan (In_Tree); -- past the project name
446
447 -- If this is inside a package, a dot followed by the
448 -- name of the package must followed the project name.
449
450 if Present (Current_Package) then
451 Expect (Tok_Dot, "`.`");
452
453 if Token /= Tok_Dot then
454 The_Project := Empty_Node;
455
456 else
457 Scan (In_Tree); -- past the dot
458 Expect (Tok_Identifier, "identifier");
459
460 if Token /= Tok_Identifier then
461 The_Project := Empty_Node;
462
463 -- If it is not the same package name, issue error
464
465 elsif
466 Token_Name /= Name_Of (Current_Package, In_Tree)
467 then
468 The_Project := Empty_Node;
469 Error_Msg
470 (Flags, "not the same package as " &
471 Get_Name_String
472 (Name_Of (Current_Package, In_Tree)),
473 Token_Ptr);
474
475 else
476 The_Package :=
477 First_Package_Of (The_Project, In_Tree);
478
479 -- Look for the package node
480
481 while Present (The_Package)
482 and then
483 Name_Of (The_Package, In_Tree) /= Token_Name
484 loop
485 The_Package :=
486 Next_Package_In_Project
487 (The_Package, In_Tree);
488 end loop;
489
490 -- If the package cannot be found in the
491 -- project, issue an error.
492
493 if No (The_Package) then
494 The_Project := Empty_Node;
495 Error_Msg_Name_2 := Project_Name;
496 Error_Msg_Name_1 := Token_Name;
497 Error_Msg
498 (Flags,
499 "package % not declared in project %",
500 Token_Ptr);
501 end if;
502
503 Scan (In_Tree); -- past the package name
504 end if;
505 end if;
506 end if;
507 end if;
508 end if;
509
510 if Present (The_Project) then
511
512 -- Looking for '<same attribute name>
513
514 Expect (Tok_Apostrophe, "`''`");
515
516 if Token /= Tok_Apostrophe then
517 The_Project := Empty_Node;
518
519 else
520 Scan (In_Tree); -- past the apostrophe
521 Expect (Tok_Identifier, "identifier");
522
523 if Token /= Tok_Identifier then
524 The_Project := Empty_Node;
525
526 else
527 -- If it is not the same attribute name, issue error
528
529 if Token_Name /= Attribute_Name then
530 The_Project := Empty_Node;
531 Error_Msg_Name_1 := Attribute_Name;
532 Error_Msg
533 (Flags, "invalid name, should be %", Token_Ptr);
534 end if;
535
536 Scan (In_Tree); -- past the attribute name
537 end if;
538 end if;
539 end if;
540
541 if No (The_Project) then
542
543 -- If there were any problem, set the attribute id to null,
544 -- so that the node will not be recorded.
545
546 Current_Attribute := Empty_Attribute;
547
548 else
549 -- Set the appropriate field in the node.
550 -- Note that the index and the expression are nil. This
551 -- characterizes full associative array attribute
552 -- declarations.
553
554 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
555 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
556 end if;
557 end;
558
559 -- Other attribute declarations (not full associative array)
560
561 else
562 declare
563 Expression_Location : constant Source_Ptr := Token_Ptr;
564 -- The location of the first token of the expression
565
566 Expression : Project_Node_Id := Empty_Node;
567 -- The expression, value for the attribute declaration
568
569 begin
570 -- Get the expression value and set it in the attribute node
571
572 Parse_Expression
573 (In_Tree => In_Tree,
574 Expression => Expression,
575 Flags => Flags,
576 Current_Project => Current_Project,
577 Current_Package => Current_Package,
578 Optional_Index => Optional_Index);
579 Set_Expression_Of (Attribute, In_Tree, To => Expression);
580
581 -- If the expression is legal, but not of the right kind
582 -- for the attribute, issue an error.
583
584 if Current_Attribute /= Empty_Attribute
585 and then Present (Expression)
586 and then Variable_Kind_Of (Current_Attribute) /=
587 Expression_Kind_Of (Expression, In_Tree)
588 then
589 if Variable_Kind_Of (Current_Attribute) = Undefined then
590 Set_Variable_Kind_Of
591 (Current_Attribute,
592 To => Expression_Kind_Of (Expression, In_Tree));
593
594 else
595 Error_Msg
596 (Flags, "wrong expression kind for attribute """ &
597 Get_Name_String
598 (Attribute_Name_Of (Current_Attribute)) &
599 """",
600 Expression_Location);
601 end if;
602 end if;
603 end;
604 end if;
605 end if;
606
607 -- If the attribute was not recognized, return an empty node.
608 -- It may be that it is not in a package to check, and the node will
609 -- not be added to the tree.
610
611 if Current_Attribute = Empty_Attribute then
612 Attribute := Empty_Node;
613 end if;
614
615 Set_End_Of_Line (Attribute);
616 Set_Previous_Line_Node (Attribute);
617 end Parse_Attribute_Declaration;
618
619 -----------------------------
620 -- Parse_Case_Construction --
621 -----------------------------
622
623 procedure Parse_Case_Construction
624 (In_Tree : Project_Node_Tree_Ref;
625 Case_Construction : out Project_Node_Id;
626 First_Attribute : Attribute_Node_Id;
627 Current_Project : Project_Node_Id;
628 Current_Package : Project_Node_Id;
629 Packages_To_Check : String_List_Access;
630 Is_Config_File : Boolean;
631 Flags : Processing_Flags)
632 is
633 Current_Item : Project_Node_Id := Empty_Node;
634 Next_Item : Project_Node_Id := Empty_Node;
635 First_Case_Item : Boolean := True;
636
637 Variable_Location : Source_Ptr := No_Location;
638
639 String_Type : Project_Node_Id := Empty_Node;
640
641 Case_Variable : Project_Node_Id := Empty_Node;
642
643 First_Declarative_Item : Project_Node_Id := Empty_Node;
644
645 First_Choice : Project_Node_Id := Empty_Node;
646
647 When_Others : Boolean := False;
648 -- Set to True when there is a "when others =>" clause
649
650 begin
651 Case_Construction :=
652 Default_Project_Node
653 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
654 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
655
656 -- Scan past "case"
657
658 Scan (In_Tree);
659
660 -- Get the switch variable
661
662 Expect (Tok_Identifier, "identifier");
663
664 if Token = Tok_Identifier then
665 Variable_Location := Token_Ptr;
666 Parse_Variable_Reference
667 (In_Tree => In_Tree,
668 Variable => Case_Variable,
669 Flags => Flags,
670 Current_Project => Current_Project,
671 Current_Package => Current_Package);
672 Set_Case_Variable_Reference_Of
673 (Case_Construction, In_Tree, To => Case_Variable);
674
675 else
676 if Token /= Tok_Is then
677 Scan (In_Tree);
678 end if;
679 end if;
680
681 if Present (Case_Variable) then
682 String_Type := String_Type_Of (Case_Variable, In_Tree);
683
684 if No (String_Type) then
685 Error_Msg (Flags,
686 "variable """ &
687 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
688 """ is not typed",
689 Variable_Location);
690 end if;
691 end if;
692
693 Expect (Tok_Is, "IS");
694
695 if Token = Tok_Is then
696 Set_End_Of_Line (Case_Construction);
697 Set_Previous_Line_Node (Case_Construction);
698 Set_Next_End_Node (Case_Construction);
699
700 -- Scan past "is"
701
702 Scan (In_Tree);
703 end if;
704
705 Start_New_Case_Construction (In_Tree, String_Type);
706
707 When_Loop :
708
709 while Token = Tok_When loop
710
711 if First_Case_Item then
712 Current_Item :=
713 Default_Project_Node
714 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
715 Set_First_Case_Item_Of
716 (Case_Construction, In_Tree, To => Current_Item);
717 First_Case_Item := False;
718
719 else
720 Next_Item :=
721 Default_Project_Node
722 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
723 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
724 Current_Item := Next_Item;
725 end if;
726
727 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
728
729 -- Scan past "when"
730
731 Scan (In_Tree);
732
733 if Token = Tok_Others then
734 When_Others := True;
735
736 -- Scan past "others"
737
738 Scan (In_Tree);
739
740 Expect (Tok_Arrow, "`=>`");
741 Set_End_Of_Line (Current_Item);
742 Set_Previous_Line_Node (Current_Item);
743
744 -- Empty_Node in Field1 of a Case_Item indicates
745 -- the "when others =>" branch.
746
747 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
748
749 Parse_Declarative_Items
750 (In_Tree => In_Tree,
751 Declarations => First_Declarative_Item,
752 In_Zone => In_Case_Construction,
753 First_Attribute => First_Attribute,
754 Current_Project => Current_Project,
755 Current_Package => Current_Package,
756 Packages_To_Check => Packages_To_Check,
757 Is_Config_File => Is_Config_File,
758 Flags => Flags);
759
760 -- "when others =>" must be the last branch, so save the
761 -- Case_Item and exit
762
763 Set_First_Declarative_Item_Of
764 (Current_Item, In_Tree, To => First_Declarative_Item);
765 exit When_Loop;
766
767 else
768 Parse_Choice_List
769 (In_Tree => In_Tree,
770 First_Choice => First_Choice,
771 Flags => Flags);
772 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
773
774 Expect (Tok_Arrow, "`=>`");
775 Set_End_Of_Line (Current_Item);
776 Set_Previous_Line_Node (Current_Item);
777
778 Parse_Declarative_Items
779 (In_Tree => In_Tree,
780 Declarations => First_Declarative_Item,
781 In_Zone => In_Case_Construction,
782 First_Attribute => First_Attribute,
783 Current_Project => Current_Project,
784 Current_Package => Current_Package,
785 Packages_To_Check => Packages_To_Check,
786 Is_Config_File => Is_Config_File,
787 Flags => Flags);
788
789 Set_First_Declarative_Item_Of
790 (Current_Item, In_Tree, To => First_Declarative_Item);
791
792 end if;
793 end loop When_Loop;
794
795 End_Case_Construction
796 (Check_All_Labels => not When_Others and not Quiet_Output,
797 Case_Location => Location_Of (Case_Construction, In_Tree),
798 Flags => Flags);
799
800 Expect (Tok_End, "`END CASE`");
801 Remove_Next_End_Node;
802
803 if Token = Tok_End then
804
805 -- Scan past "end"
806
807 Scan (In_Tree);
808
809 Expect (Tok_Case, "CASE");
810
811 end if;
812
813 -- Scan past "case"
814
815 Scan (In_Tree);
816
817 Expect (Tok_Semicolon, "`;`");
818 Set_Previous_End_Node (Case_Construction);
819
820 end Parse_Case_Construction;
821
822 -----------------------------
823 -- Parse_Declarative_Items --
824 -----------------------------
825
826 procedure Parse_Declarative_Items
827 (In_Tree : Project_Node_Tree_Ref;
828 Declarations : out Project_Node_Id;
829 In_Zone : Zone;
830 First_Attribute : Attribute_Node_Id;
831 Current_Project : Project_Node_Id;
832 Current_Package : Project_Node_Id;
833 Packages_To_Check : String_List_Access;
834 Is_Config_File : Boolean;
835 Flags : Processing_Flags)
836 is
837 Current_Declarative_Item : Project_Node_Id := Empty_Node;
838 Next_Declarative_Item : Project_Node_Id := Empty_Node;
839 Current_Declaration : Project_Node_Id := Empty_Node;
840 Item_Location : Source_Ptr := No_Location;
841
842 begin
843 Declarations := Empty_Node;
844
845 loop
846 -- We are always positioned at the token that precedes the first
847 -- token of the declarative element. Scan past it.
848
849 Scan (In_Tree);
850
851 Item_Location := Token_Ptr;
852
853 case Token is
854 when Tok_Identifier =>
855
856 if In_Zone = In_Case_Construction then
857
858 -- Check if the variable has already been declared
859
860 declare
861 The_Variable : Project_Node_Id := Empty_Node;
862
863 begin
864 if Present (Current_Package) then
865 The_Variable :=
866 First_Variable_Of (Current_Package, In_Tree);
867 elsif Present (Current_Project) then
868 The_Variable :=
869 First_Variable_Of (Current_Project, In_Tree);
870 end if;
871
872 while Present (The_Variable)
873 and then Name_Of (The_Variable, In_Tree) /=
874 Token_Name
875 loop
876 The_Variable := Next_Variable (The_Variable, In_Tree);
877 end loop;
878
879 -- It is an error to declare a variable in a case
880 -- construction for the first time.
881
882 if No (The_Variable) then
883 Error_Msg
884 (Flags,
885 "a variable cannot be declared " &
886 "for the first time here",
887 Token_Ptr);
888 end if;
889 end;
890 end if;
891
892 Parse_Variable_Declaration
893 (In_Tree,
894 Current_Declaration,
895 Current_Project => Current_Project,
896 Current_Package => Current_Package,
897 Flags => Flags);
898
899 Set_End_Of_Line (Current_Declaration);
900 Set_Previous_Line_Node (Current_Declaration);
901
902 when Tok_For =>
903
904 Parse_Attribute_Declaration
905 (In_Tree => In_Tree,
906 Attribute => Current_Declaration,
907 First_Attribute => First_Attribute,
908 Current_Project => Current_Project,
909 Current_Package => Current_Package,
910 Packages_To_Check => Packages_To_Check,
911 Flags => Flags);
912
913 Set_End_Of_Line (Current_Declaration);
914 Set_Previous_Line_Node (Current_Declaration);
915
916 when Tok_Null =>
917
918 Scan (In_Tree); -- past "null"
919
920 when Tok_Package =>
921
922 -- Package declaration
923
924 if In_Zone /= In_Project then
925 Error_Msg
926 (Flags, "a package cannot be declared here", Token_Ptr);
927 end if;
928
929 Parse_Package_Declaration
930 (In_Tree => In_Tree,
931 Package_Declaration => Current_Declaration,
932 Current_Project => Current_Project,
933 Packages_To_Check => Packages_To_Check,
934 Is_Config_File => Is_Config_File,
935 Flags => Flags);
936
937 Set_Previous_End_Node (Current_Declaration);
938
939 when Tok_Type =>
940
941 -- Type String Declaration
942
943 if In_Zone /= In_Project then
944 Error_Msg (Flags,
945 "a string type cannot be declared here",
946 Token_Ptr);
947 end if;
948
949 Parse_String_Type_Declaration
950 (In_Tree => In_Tree,
951 String_Type => Current_Declaration,
952 Current_Project => Current_Project,
953 Flags => Flags);
954
955 Set_End_Of_Line (Current_Declaration);
956 Set_Previous_Line_Node (Current_Declaration);
957
958 when Tok_Case =>
959
960 -- Case construction
961
962 Parse_Case_Construction
963 (In_Tree => In_Tree,
964 Case_Construction => Current_Declaration,
965 First_Attribute => First_Attribute,
966 Current_Project => Current_Project,
967 Current_Package => Current_Package,
968 Packages_To_Check => Packages_To_Check,
969 Is_Config_File => Is_Config_File,
970 Flags => Flags);
971
972 Set_Previous_End_Node (Current_Declaration);
973
974 when others =>
975 exit;
976
977 -- We are leaving Parse_Declarative_Items positioned
978 -- at the first token after the list of declarative items.
979 -- It could be "end" (for a project, a package declaration or
980 -- a case construction) or "when" (for a case construction)
981
982 end case;
983
984 Expect (Tok_Semicolon, "`;` after declarative items");
985
986 -- Insert an N_Declarative_Item in the tree, but only if
987 -- Current_Declaration is not an empty node.
988
989 if Present (Current_Declaration) then
990 if No (Current_Declarative_Item) then
991 Current_Declarative_Item :=
992 Default_Project_Node
993 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
994 Declarations := Current_Declarative_Item;
995
996 else
997 Next_Declarative_Item :=
998 Default_Project_Node
999 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1000 Set_Next_Declarative_Item
1001 (Current_Declarative_Item, In_Tree,
1002 To => Next_Declarative_Item);
1003 Current_Declarative_Item := Next_Declarative_Item;
1004 end if;
1005
1006 Set_Current_Item_Node
1007 (Current_Declarative_Item, In_Tree,
1008 To => Current_Declaration);
1009 Set_Location_Of
1010 (Current_Declarative_Item, In_Tree, To => Item_Location);
1011 end if;
1012 end loop;
1013 end Parse_Declarative_Items;
1014
1015 -------------------------------
1016 -- Parse_Package_Declaration --
1017 -------------------------------
1018
1019 procedure Parse_Package_Declaration
1020 (In_Tree : Project_Node_Tree_Ref;
1021 Package_Declaration : out Project_Node_Id;
1022 Current_Project : Project_Node_Id;
1023 Packages_To_Check : String_List_Access;
1024 Is_Config_File : Boolean;
1025 Flags : Processing_Flags)
1026 is
1027 First_Attribute : Attribute_Node_Id := Empty_Attribute;
1028 Current_Package : Package_Node_Id := Empty_Package;
1029 First_Declarative_Item : Project_Node_Id := Empty_Node;
1030 Package_Location : constant Source_Ptr := Token_Ptr;
1031 Renaming : Boolean := False;
1032 Extending : Boolean := False;
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 Renaming := True;
1154 elsif Token = Tok_Extends then
1155 Extending := True;
1156 end if;
1157
1158 if Renaming or else Extending then
1159 if Is_Config_File then
1160 Error_Msg
1161 (Flags,
1162 "no package rename or extension in configuration projects",
1163 Token_Ptr);
1164 end if;
1165
1166 -- Scan past "renames" or "extends"
1167
1168 Scan (In_Tree);
1169
1170 Expect (Tok_Identifier, "identifier");
1171
1172 if Token = Tok_Identifier then
1173 declare
1174 Project_Name : constant Name_Id := Token_Name;
1175
1176 Clause : Project_Node_Id :=
1177 First_With_Clause_Of (Current_Project, In_Tree);
1178 The_Project : Project_Node_Id := Empty_Node;
1179 Extended : constant Project_Node_Id :=
1180 Extended_Project_Of
1181 (Project_Declaration_Of
1182 (Current_Project, In_Tree),
1183 In_Tree);
1184 begin
1185 while Present (Clause) loop
1186 -- Only non limited imported projects may be used in a
1187 -- renames declaration.
1188
1189 The_Project :=
1190 Non_Limited_Project_Node_Of (Clause, In_Tree);
1191 exit when Present (The_Project)
1192 and then Name_Of (The_Project, In_Tree) = Project_Name;
1193 Clause := Next_With_Clause_Of (Clause, In_Tree);
1194 end loop;
1195
1196 if No (Clause) then
1197 -- As we have not found the project in the imports, we check
1198 -- if it's the name of an eventual extended project.
1199
1200 if Present (Extended)
1201 and then Name_Of (Extended, In_Tree) = Project_Name
1202 then
1203 Set_Project_Of_Renamed_Package_Of
1204 (Package_Declaration, In_Tree, To => Extended);
1205 else
1206 Error_Msg_Name_1 := Project_Name;
1207 Error_Msg
1208 (Flags,
1209 "% is not an imported or extended project", Token_Ptr);
1210 end if;
1211 else
1212 Set_Project_Of_Renamed_Package_Of
1213 (Package_Declaration, In_Tree, To => The_Project);
1214 end if;
1215 end;
1216
1217 Scan (In_Tree);
1218 Expect (Tok_Dot, "`.`");
1219
1220 if Token = Tok_Dot then
1221 Scan (In_Tree);
1222 Expect (Tok_Identifier, "identifier");
1223
1224 if Token = Tok_Identifier then
1225 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1226 Error_Msg (Flags, "not the same package name", Token_Ptr);
1227 elsif
1228 Present (Project_Of_Renamed_Package_Of
1229 (Package_Declaration, In_Tree))
1230 then
1231 declare
1232 Current : Project_Node_Id :=
1233 First_Package_Of
1234 (Project_Of_Renamed_Package_Of
1235 (Package_Declaration, In_Tree),
1236 In_Tree);
1237
1238 begin
1239 while Present (Current)
1240 and then Name_Of (Current, In_Tree) /= Token_Name
1241 loop
1242 Current :=
1243 Next_Package_In_Project (Current, In_Tree);
1244 end loop;
1245
1246 if No (Current) then
1247 Error_Msg
1248 (Flags, """" &
1249 Get_Name_String (Token_Name) &
1250 """ is not a package declared by the project",
1251 Token_Ptr);
1252 end if;
1253 end;
1254 end if;
1255
1256 Scan (In_Tree);
1257 end if;
1258 end if;
1259 end if;
1260 end if;
1261
1262 if Renaming then
1263 Expect (Tok_Semicolon, "`;`");
1264 Set_End_Of_Line (Package_Declaration);
1265 Set_Previous_Line_Node (Package_Declaration);
1266
1267 elsif Token = Tok_Is then
1268 Set_End_Of_Line (Package_Declaration);
1269 Set_Previous_Line_Node (Package_Declaration);
1270 Set_Next_End_Node (Package_Declaration);
1271
1272 Parse_Declarative_Items
1273 (In_Tree => In_Tree,
1274 Declarations => First_Declarative_Item,
1275 In_Zone => In_Package,
1276 First_Attribute => First_Attribute,
1277 Current_Project => Current_Project,
1278 Current_Package => Package_Declaration,
1279 Packages_To_Check => Packages_To_Check,
1280 Is_Config_File => Is_Config_File,
1281 Flags => Flags);
1282
1283 Set_First_Declarative_Item_Of
1284 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1285
1286 Expect (Tok_End, "END");
1287
1288 if Token = Tok_End then
1289
1290 -- Scan past "end"
1291
1292 Scan (In_Tree);
1293 end if;
1294
1295 -- We should have the name of the package after "end"
1296
1297 Expect (Tok_Identifier, "identifier");
1298
1299 if Token = Tok_Identifier
1300 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1301 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1302 then
1303 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1304 Error_Msg (Flags, "expected %%", Token_Ptr);
1305 end if;
1306
1307 if Token /= Tok_Semicolon then
1308
1309 -- Scan past the package name
1310
1311 Scan (In_Tree);
1312 end if;
1313
1314 Expect (Tok_Semicolon, "`;`");
1315 Remove_Next_End_Node;
1316
1317 else
1318 Error_Msg (Flags, "expected IS", Token_Ptr);
1319 end if;
1320
1321 end Parse_Package_Declaration;
1322
1323 -----------------------------------
1324 -- Parse_String_Type_Declaration --
1325 -----------------------------------
1326
1327 procedure Parse_String_Type_Declaration
1328 (In_Tree : Project_Node_Tree_Ref;
1329 String_Type : out Project_Node_Id;
1330 Current_Project : Project_Node_Id;
1331 Flags : Processing_Flags)
1332 is
1333 Current : Project_Node_Id := Empty_Node;
1334 First_String : Project_Node_Id := Empty_Node;
1335
1336 begin
1337 String_Type :=
1338 Default_Project_Node
1339 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1340
1341 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1342
1343 -- Scan past "type"
1344
1345 Scan (In_Tree);
1346
1347 Expect (Tok_Identifier, "identifier");
1348
1349 if Token = Tok_Identifier then
1350 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1351
1352 Current := First_String_Type_Of (Current_Project, In_Tree);
1353 while Present (Current)
1354 and then
1355 Name_Of (Current, In_Tree) /= Token_Name
1356 loop
1357 Current := Next_String_Type (Current, In_Tree);
1358 end loop;
1359
1360 if Present (Current) then
1361 Error_Msg (Flags,
1362 "duplicate string type name """ &
1363 Get_Name_String (Token_Name) &
1364 """",
1365 Token_Ptr);
1366 else
1367 Current := First_Variable_Of (Current_Project, In_Tree);
1368 while Present (Current)
1369 and then Name_Of (Current, In_Tree) /= Token_Name
1370 loop
1371 Current := Next_Variable (Current, In_Tree);
1372 end loop;
1373
1374 if Present (Current) then
1375 Error_Msg (Flags,
1376 """" &
1377 Get_Name_String (Token_Name) &
1378 """ is already a variable name", Token_Ptr);
1379 else
1380 Set_Next_String_Type
1381 (String_Type, In_Tree,
1382 To => First_String_Type_Of (Current_Project, In_Tree));
1383 Set_First_String_Type_Of
1384 (Current_Project, In_Tree, To => String_Type);
1385 end if;
1386 end if;
1387
1388 -- Scan past the name
1389
1390 Scan (In_Tree);
1391 end if;
1392
1393 Expect (Tok_Is, "IS");
1394
1395 if Token = Tok_Is then
1396 Scan (In_Tree);
1397 end if;
1398
1399 Expect (Tok_Left_Paren, "`(`");
1400
1401 if Token = Tok_Left_Paren then
1402 Scan (In_Tree);
1403 end if;
1404
1405 Parse_String_Type_List
1406 (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
1407 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1408
1409 Expect (Tok_Right_Paren, "`)`");
1410
1411 if Token = Tok_Right_Paren then
1412 Scan (In_Tree);
1413 end if;
1414
1415 end Parse_String_Type_Declaration;
1416
1417 --------------------------------
1418 -- Parse_Variable_Declaration --
1419 --------------------------------
1420
1421 procedure Parse_Variable_Declaration
1422 (In_Tree : Project_Node_Tree_Ref;
1423 Variable : out Project_Node_Id;
1424 Current_Project : Project_Node_Id;
1425 Current_Package : Project_Node_Id;
1426 Flags : Processing_Flags)
1427 is
1428 Expression_Location : Source_Ptr;
1429 String_Type_Name : Name_Id := No_Name;
1430 Project_String_Type_Name : Name_Id := No_Name;
1431 Type_Location : Source_Ptr := No_Location;
1432 Project_Location : Source_Ptr := No_Location;
1433 Expression : Project_Node_Id := Empty_Node;
1434 Variable_Name : constant Name_Id := Token_Name;
1435 OK : Boolean := True;
1436
1437 begin
1438 Variable :=
1439 Default_Project_Node
1440 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1441 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1442 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1443
1444 -- Scan past the variable name
1445
1446 Scan (In_Tree);
1447
1448 if Token = Tok_Colon then
1449
1450 -- Typed string variable declaration
1451
1452 Scan (In_Tree);
1453 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1454 Expect (Tok_Identifier, "identifier");
1455
1456 OK := Token = Tok_Identifier;
1457
1458 if OK then
1459 String_Type_Name := Token_Name;
1460 Type_Location := Token_Ptr;
1461 Scan (In_Tree);
1462
1463 if Token = Tok_Dot then
1464 Project_String_Type_Name := String_Type_Name;
1465 Project_Location := Type_Location;
1466
1467 -- Scan past the dot
1468
1469 Scan (In_Tree);
1470 Expect (Tok_Identifier, "identifier");
1471
1472 if Token = Tok_Identifier then
1473 String_Type_Name := Token_Name;
1474 Type_Location := Token_Ptr;
1475 Scan (In_Tree);
1476 else
1477 OK := False;
1478 end if;
1479 end if;
1480
1481 if OK then
1482 declare
1483 Proj : Project_Node_Id := Current_Project;
1484 Current : Project_Node_Id := Empty_Node;
1485
1486 begin
1487 if Project_String_Type_Name /= No_Name then
1488 declare
1489 The_Project_Name_And_Node : constant
1490 Tree_Private_Part.Project_Name_And_Node :=
1491 Tree_Private_Part.Projects_Htable.Get
1492 (In_Tree.Projects_HT, Project_String_Type_Name);
1493
1494 use Tree_Private_Part;
1495
1496 begin
1497 if The_Project_Name_And_Node =
1498 Tree_Private_Part.No_Project_Name_And_Node
1499 then
1500 Error_Msg (Flags,
1501 "unknown project """ &
1502 Get_Name_String
1503 (Project_String_Type_Name) &
1504 """",
1505 Project_Location);
1506 Current := Empty_Node;
1507 else
1508 Current :=
1509 First_String_Type_Of
1510 (The_Project_Name_And_Node.Node, In_Tree);
1511 while
1512 Present (Current)
1513 and then
1514 Name_Of (Current, In_Tree) /= String_Type_Name
1515 loop
1516 Current := Next_String_Type (Current, In_Tree);
1517 end loop;
1518 end if;
1519 end;
1520
1521 else
1522 -- Look for a string type with the correct name in this
1523 -- project or in any of its ancestors.
1524
1525 loop
1526 Current :=
1527 First_String_Type_Of (Proj, In_Tree);
1528 while
1529 Present (Current)
1530 and then
1531 Name_Of (Current, In_Tree) /= String_Type_Name
1532 loop
1533 Current := Next_String_Type (Current, In_Tree);
1534 end loop;
1535
1536 exit when Present (Current);
1537
1538 Proj := Parent_Project_Of (Proj, In_Tree);
1539 exit when No (Proj);
1540 end loop;
1541 end if;
1542
1543 if No (Current) then
1544 Error_Msg (Flags,
1545 "unknown string type """ &
1546 Get_Name_String (String_Type_Name) &
1547 """",
1548 Type_Location);
1549 OK := False;
1550
1551 else
1552 Set_String_Type_Of
1553 (Variable, In_Tree, To => Current);
1554 end if;
1555 end;
1556 end if;
1557 end if;
1558 end if;
1559
1560 Expect (Tok_Colon_Equal, "`:=`");
1561
1562 OK := OK and then Token = Tok_Colon_Equal;
1563
1564 if Token = Tok_Colon_Equal then
1565 Scan (In_Tree);
1566 end if;
1567
1568 -- Get the single string or string list value
1569
1570 Expression_Location := Token_Ptr;
1571
1572 Parse_Expression
1573 (In_Tree => In_Tree,
1574 Expression => Expression,
1575 Flags => Flags,
1576 Current_Project => Current_Project,
1577 Current_Package => Current_Package,
1578 Optional_Index => False);
1579 Set_Expression_Of (Variable, In_Tree, To => Expression);
1580
1581 if Present (Expression) then
1582 -- A typed string must have a single string value, not a list
1583
1584 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1585 and then Expression_Kind_Of (Expression, In_Tree) = List
1586 then
1587 Error_Msg
1588 (Flags,
1589 "expression must be a single string", Expression_Location);
1590 end if;
1591
1592 Set_Expression_Kind_Of
1593 (Variable, In_Tree,
1594 To => Expression_Kind_Of (Expression, In_Tree));
1595 end if;
1596
1597 if OK then
1598 declare
1599 The_Variable : Project_Node_Id := Empty_Node;
1600
1601 begin
1602 if Present (Current_Package) then
1603 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1604 elsif Present (Current_Project) then
1605 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1606 end if;
1607
1608 while Present (The_Variable)
1609 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1610 loop
1611 The_Variable := Next_Variable (The_Variable, In_Tree);
1612 end loop;
1613
1614 if No (The_Variable) then
1615 if Present (Current_Package) then
1616 Set_Next_Variable
1617 (Variable, In_Tree,
1618 To => First_Variable_Of (Current_Package, In_Tree));
1619 Set_First_Variable_Of
1620 (Current_Package, In_Tree, To => Variable);
1621
1622 elsif Present (Current_Project) then
1623 Set_Next_Variable
1624 (Variable, In_Tree,
1625 To => First_Variable_Of (Current_Project, In_Tree));
1626 Set_First_Variable_Of
1627 (Current_Project, In_Tree, To => Variable);
1628 end if;
1629
1630 else
1631 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1632 if Expression_Kind_Of (The_Variable, In_Tree) =
1633 Undefined
1634 then
1635 Set_Expression_Kind_Of
1636 (The_Variable, In_Tree,
1637 To => Expression_Kind_Of (Variable, In_Tree));
1638
1639 else
1640 if Expression_Kind_Of (The_Variable, In_Tree) /=
1641 Expression_Kind_Of (Variable, In_Tree)
1642 then
1643 Error_Msg (Flags,
1644 "wrong expression kind for variable """ &
1645 Get_Name_String
1646 (Name_Of (The_Variable, In_Tree)) &
1647 """",
1648 Expression_Location);
1649 end if;
1650 end if;
1651 end if;
1652 end if;
1653 end;
1654 end if;
1655 end Parse_Variable_Declaration;
1656
1657 end Prj.Dect;
Mirror of the offical gcc git repository hosted at gcc.gnu.org