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