projects / gcc.git / blob
? search:


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