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