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