OpenCores
URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [prj-dect.adb] - Blame information for rev 16

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 12 jlechner
------------------------------------------------------------------------------
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-2005, 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 2,  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 COPYING.  If not, write --
19
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
20
-- Boston, MA 02110-1301, USA.                                              --
21
--                                                                          --
22
-- GNAT was originally developed  by the GNAT team at  New York University. --
23
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
24
--                                                                          --
25
------------------------------------------------------------------------------
26
 
27
with Err_Vars;    use Err_Vars;
28
with Namet;       use Namet;
29
with Opt;         use Opt;
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 Prj.Attr;    use Prj.Attr;
35
with Prj.Attr.PM; use Prj.Attr.PM;
36
with Uintp;       use Uintp;
37
 
38
package body Prj.Dect is
39
 
40
   type Zone is (In_Project, In_Package, In_Case_Construction);
41
   --  Used to indicate if we are parsing a package (In_Package),
42
   --  a case construction (In_Case_Construction) or none of those two
43
   --  (In_Project).
44
 
45
   procedure Parse_Attribute_Declaration
46
     (In_Tree           : Project_Node_Tree_Ref;
47
      Attribute         : out Project_Node_Id;
48
      First_Attribute   : Attribute_Node_Id;
49
      Current_Project   : Project_Node_Id;
50
      Current_Package   : Project_Node_Id;
51
      Packages_To_Check : String_List_Access);
52
   --  Parse an attribute declaration
53
 
54
   procedure Parse_Case_Construction
55
     (In_Tree           : Project_Node_Tree_Ref;
56
      Case_Construction : out Project_Node_Id;
57
      First_Attribute   : Attribute_Node_Id;
58
      Current_Project   : Project_Node_Id;
59
      Current_Package   : Project_Node_Id;
60
      Packages_To_Check : String_List_Access);
61
   --  Parse a case construction
62
 
63
   procedure Parse_Declarative_Items
64
     (In_Tree           : Project_Node_Tree_Ref;
65
      Declarations      : out Project_Node_Id;
66
      In_Zone           : Zone;
67
      First_Attribute   : Attribute_Node_Id;
68
      Current_Project   : Project_Node_Id;
69
      Current_Package   : Project_Node_Id;
70
      Packages_To_Check : String_List_Access);
71
   --  Parse declarative items. Depending on In_Zone, some declarative
72
   --  items may be forbiden.
73
 
74
   procedure Parse_Package_Declaration
75
     (In_Tree             : Project_Node_Tree_Ref;
76
      Package_Declaration : out Project_Node_Id;
77
      Current_Project     : Project_Node_Id;
78
      Packages_To_Check   : String_List_Access);
79
   --  Parse a package declaration
80
 
81
   procedure Parse_String_Type_Declaration
82
     (In_Tree         : Project_Node_Tree_Ref;
83
      String_Type     : out Project_Node_Id;
84
      Current_Project : Project_Node_Id);
85
   --  type <name> is ( <literal_string> { , <literal_string> } ) ;
86
 
87
   procedure Parse_Variable_Declaration
88
     (In_Tree         : Project_Node_Tree_Ref;
89
      Variable        : out Project_Node_Id;
90
      Current_Project : Project_Node_Id;
91
      Current_Package : Project_Node_Id);
92
   --  Parse a variable assignment
93
   --  <variable_Name> := <expression>; OR
94
   --  <variable_Name> : <string_type_Name> := <string_expression>;
95
 
96
   -----------
97
   -- Parse --
98
   -----------
99
 
100
   procedure Parse
101
     (In_Tree           : Project_Node_Tree_Ref;
102
      Declarations      : out Project_Node_Id;
103
      Current_Project   : Project_Node_Id;
104
      Extends           : Project_Node_Id;
105
      Packages_To_Check : String_List_Access)
106
   is
107
      First_Declarative_Item : Project_Node_Id := Empty_Node;
108
 
109
   begin
110
      Declarations :=
111
        Default_Project_Node
112
          (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
113
      Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
114
      Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
115
      Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
116
      Parse_Declarative_Items
117
        (Declarations      => First_Declarative_Item,
118
         In_Tree           => In_Tree,
119
         In_Zone           => In_Project,
120
         First_Attribute   => Prj.Attr.Attribute_First,
121
         Current_Project   => Current_Project,
122
         Current_Package   => Empty_Node,
123
         Packages_To_Check => Packages_To_Check);
124
      Set_First_Declarative_Item_Of
125
        (Declarations, In_Tree, To => First_Declarative_Item);
126
   end Parse;
127
 
128
   ---------------------------------
129
   -- Parse_Attribute_Declaration --
130
   ---------------------------------
131
 
132
   procedure Parse_Attribute_Declaration
133
     (In_Tree           : Project_Node_Tree_Ref;
134
      Attribute         : out Project_Node_Id;
135
      First_Attribute   : Attribute_Node_Id;
136
      Current_Project   : Project_Node_Id;
137
      Current_Package   : Project_Node_Id;
138
      Packages_To_Check : String_List_Access)
139
   is
140
      Current_Attribute      : Attribute_Node_Id := First_Attribute;
141
      Full_Associative_Array : Boolean           := False;
142
      Attribute_Name         : Name_Id           := No_Name;
143
      Optional_Index         : Boolean           := False;
144
      Pkg_Id                 : Package_Node_Id   := Empty_Package;
145
      Warning                : Boolean           := False;
146
 
147
   begin
148
      Attribute :=
149
        Default_Project_Node
150
          (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
151
      Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
152
      Set_Previous_Line_Node (Attribute);
153
 
154
      --  Scan past "for"
155
 
156
      Scan (In_Tree);
157
 
158
      --  Body may be an attribute name
159
 
160
      if Token = Tok_Body then
161
         Token := Tok_Identifier;
162
         Token_Name := Snames.Name_Body;
163
      end if;
164
 
165
      Expect (Tok_Identifier, "identifier");
166
 
167
      if Token = Tok_Identifier then
168
         Attribute_Name := Token_Name;
169
         Set_Name_Of (Attribute, In_Tree, To => Token_Name);
170
         Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
171
 
172
         --  Find the attribute
173
 
174
         Current_Attribute :=
175
           Attribute_Node_Id_Of (Token_Name, First_Attribute);
176
 
177
         --  If the attribute cannot be found, create the attribute if inside
178
         --  an unknown package.
179
 
180
         if Current_Attribute = Empty_Attribute then
181
            if Current_Package /= Empty_Node
182
              and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
183
            then
184
               Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
185
               Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
186
               Error_Msg_Name_1 := Token_Name;
187
               Error_Msg ("?unknown attribute {", Token_Ptr);
188
 
189
            else
190
               --  If not a valid attribute name, issue an error, or a warning
191
               --  if inside a package that does not need to be checked.
192
 
193
               Warning := Current_Package /= Empty_Node and then
194
                          Packages_To_Check /= All_Packages;
195
 
196
               if Warning then
197
 
198
                  --  Check that we are not in a package to check
199
 
200
                  Get_Name_String (Name_Of (Current_Package, In_Tree));
201
 
202
                  for Index in Packages_To_Check'Range loop
203
                     if Name_Buffer (1 .. Name_Len) =
204
                       Packages_To_Check (Index).all
205
                     then
206
                        Warning := False;
207
                        exit;
208
                     end if;
209
                  end loop;
210
               end if;
211
 
212
               Error_Msg_Name_1 := Token_Name;
213
               Error_Msg_Warn := Warning;
214
               Error_Msg ("<undefined attribute {", Token_Ptr);
215
            end if;
216
 
217
         --  Set, if appropriate the index case insensitivity flag
218
 
219
         elsif Attribute_Kind_Of (Current_Attribute) in
220
                 Case_Insensitive_Associative_Array ..
221
                 Optional_Index_Case_Insensitive_Associative_Array
222
         then
223
            Set_Case_Insensitive (Attribute, In_Tree, To => True);
224
         end if;
225
 
226
         Scan (In_Tree); --  past the attribute name
227
      end if;
228
 
229
      --  Change obsolete names of attributes to the new names
230
 
231
      if Current_Package /= Empty_Node
232
        and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
233
      then
234
         case Name_Of (Attribute, In_Tree) is
235
         when Snames.Name_Specification =>
236
            Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
237
 
238
         when Snames.Name_Specification_Suffix =>
239
            Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
240
 
241
         when Snames.Name_Implementation =>
242
            Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
243
 
244
         when Snames.Name_Implementation_Suffix =>
245
            Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
246
 
247
         when others =>
248
            null;
249
         end case;
250
      end if;
251
 
252
      --  Associative array attributes
253
 
254
      if Token = Tok_Left_Paren then
255
 
256
         --  If the attribute is not an associative array attribute, report
257
         --  an error. If this information is still unknown, set the kind
258
         --  to Associative_Array.
259
 
260
         if Current_Attribute /= Empty_Attribute
261
           and then Attribute_Kind_Of (Current_Attribute) = Single
262
         then
263
            Error_Msg ("the attribute """ &
264
                       Get_Name_String
265
                          (Attribute_Name_Of (Current_Attribute)) &
266
                       """ cannot be an associative array",
267
                       Location_Of (Attribute, In_Tree));
268
 
269
         elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
270
            Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
271
         end if;
272
 
273
         Scan (In_Tree); --  past the left parenthesis
274
         Expect (Tok_String_Literal, "literal string");
275
 
276
         if Token = Tok_String_Literal then
277
            Set_Associative_Array_Index_Of (Attribute, In_Tree, Token_Name);
278
            Scan (In_Tree); --  past the literal string index
279
 
280
            if Token = Tok_At then
281
               case Attribute_Kind_Of (Current_Attribute) is
282
                  when Optional_Index_Associative_Array |
283
                       Optional_Index_Case_Insensitive_Associative_Array =>
284
                     Scan (In_Tree);
285
                     Expect (Tok_Integer_Literal, "integer literal");
286
 
287
                     if Token = Tok_Integer_Literal then
288
 
289
                        --  Set the source index value from given literal
290
 
291
                        declare
292
                           Index : constant Int :=
293
                                     UI_To_Int (Int_Literal_Value);
294
                        begin
295
                           if Index = 0 then
296
                              Error_Msg ("index cannot be zero", Token_Ptr);
297
                           else
298
                              Set_Source_Index_Of
299
                                (Attribute, In_Tree, To => Index);
300
                           end if;
301
                        end;
302
 
303
                        Scan (In_Tree);
304
                     end if;
305
 
306
                  when others =>
307
                     Error_Msg ("index not allowed here", Token_Ptr);
308
                     Scan (In_Tree);
309
 
310
                     if Token = Tok_Integer_Literal then
311
                        Scan (In_Tree);
312
                     end if;
313
               end case;
314
            end if;
315
         end if;
316
 
317
         Expect (Tok_Right_Paren, "`)`");
318
 
319
         if Token = Tok_Right_Paren then
320
            Scan (In_Tree); --  past the right parenthesis
321
         end if;
322
 
323
      else
324
         --  If it is an associative array attribute and there are no left
325
         --  parenthesis, then this is a full associative array declaration.
326
         --  Flag it as such for later processing of its value.
327
 
328
         if Current_Attribute /= Empty_Attribute
329
           and then
330
             Attribute_Kind_Of (Current_Attribute) /= Single
331
         then
332
            if Attribute_Kind_Of (Current_Attribute) = Unknown then
333
               Set_Attribute_Kind_Of (Current_Attribute, To => Single);
334
 
335
            else
336
               Full_Associative_Array := True;
337
            end if;
338
         end if;
339
      end if;
340
 
341
      --  Set the expression kind of the attribute
342
 
343
      if Current_Attribute /= Empty_Attribute then
344
         Set_Expression_Kind_Of
345
           (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
346
         Optional_Index := Optional_Index_Of (Current_Attribute);
347
      end if;
348
 
349
      Expect (Tok_Use, "USE");
350
 
351
      if Token = Tok_Use then
352
         Scan (In_Tree);
353
 
354
         if Full_Associative_Array then
355
 
356
            --  Expect <project>'<same_attribute_name>, or
357
            --  <project>.<same_package_name>'<same_attribute_name>
358
 
359
            declare
360
               The_Project : Project_Node_Id := Empty_Node;
361
               --  The node of the project where the associative array is
362
               --  declared.
363
 
364
               The_Package : Project_Node_Id := Empty_Node;
365
               --  The node of the package where the associative array is
366
               --  declared, if any.
367
 
368
               Project_Name : Name_Id := No_Name;
369
               --  The name of the project where the associative array is
370
               --  declared.
371
 
372
               Location : Source_Ptr := No_Location;
373
               --  The location of the project name
374
 
375
            begin
376
               Expect (Tok_Identifier, "identifier");
377
 
378
               if Token = Tok_Identifier then
379
                  Location := Token_Ptr;
380
 
381
                  --  Find the project node in the imported project or
382
                  --  in the project being extended.
383
 
384
                  The_Project := Imported_Or_Extended_Project_Of
385
                                   (Current_Project, In_Tree, Token_Name);
386
 
387
                  if The_Project = Empty_Node then
388
                     Error_Msg ("unknown project", Location);
389
                     Scan (In_Tree); --  past the project name
390
 
391
                  else
392
                     Project_Name := Token_Name;
393
                     Scan (In_Tree); --  past the project name
394
 
395
                     --  If this is inside a package, a dot followed by the
396
                     --  name of the package must followed the project name.
397
 
398
                     if Current_Package /= Empty_Node then
399
                        Expect (Tok_Dot, "`.`");
400
 
401
                        if Token /= Tok_Dot then
402
                           The_Project := Empty_Node;
403
 
404
                        else
405
                           Scan (In_Tree); --  past the dot
406
                           Expect (Tok_Identifier, "identifier");
407
 
408
                           if Token /= Tok_Identifier then
409
                              The_Project := Empty_Node;
410
 
411
                           --  If it is not the same package name, issue error
412
 
413
                           elsif
414
                             Token_Name /= Name_Of (Current_Package, In_Tree)
415
                           then
416
                              The_Project := Empty_Node;
417
                              Error_Msg
418
                                ("not the same package as " &
419
                                 Get_Name_String
420
                                   (Name_Of (Current_Package, In_Tree)),
421
                                 Token_Ptr);
422
 
423
                           else
424
                              The_Package :=
425
                                First_Package_Of (The_Project, In_Tree);
426
 
427
                              --  Look for the package node
428
 
429
                              while The_Package /= Empty_Node
430
                                and then
431
                                Name_Of (The_Package, In_Tree) /= Token_Name
432
                              loop
433
                                 The_Package :=
434
                                   Next_Package_In_Project
435
                                     (The_Package, In_Tree);
436
                              end loop;
437
 
438
                              --  If the package cannot be found in the
439
                              --  project, issue an error.
440
 
441
                              if The_Package = Empty_Node then
442
                                 The_Project := Empty_Node;
443
                                 Error_Msg_Name_2 := Project_Name;
444
                                 Error_Msg_Name_1 := Token_Name;
445
                                 Error_Msg
446
                                   ("package % not declared in project %",
447
                                   Token_Ptr);
448
                              end if;
449
 
450
                              Scan (In_Tree); --  past the package name
451
                           end if;
452
                        end if;
453
                     end if;
454
                  end if;
455
               end if;
456
 
457
               if The_Project /= Empty_Node then
458
 
459
                  --  Looking for '<same attribute name>
460
 
461
                  Expect (Tok_Apostrophe, "`''`");
462
 
463
                  if Token /= Tok_Apostrophe then
464
                     The_Project := Empty_Node;
465
 
466
                  else
467
                     Scan (In_Tree); --  past the apostrophe
468
                     Expect (Tok_Identifier, "identifier");
469
 
470
                     if Token /= Tok_Identifier then
471
                        The_Project := Empty_Node;
472
 
473
                     else
474
                        --  If it is not the same attribute name, issue error
475
 
476
                        if Token_Name /= Attribute_Name then
477
                           The_Project := Empty_Node;
478
                           Error_Msg_Name_1 := Attribute_Name;
479
                           Error_Msg ("invalid name, should be %", Token_Ptr);
480
                        end if;
481
 
482
                        Scan (In_Tree); --  past the attribute name
483
                     end if;
484
                  end if;
485
               end if;
486
 
487
               if The_Project = Empty_Node then
488
 
489
                  --  If there were any problem, set the attribute id to null,
490
                  --  so that the node will not be recorded.
491
 
492
                  Current_Attribute := Empty_Attribute;
493
 
494
               else
495
                  --  Set the appropriate field in the node.
496
                  --  Note that the index and the expression are nil. This
497
                  --  characterizes full associative array attribute
498
                  --  declarations.
499
 
500
                  Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
501
                  Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
502
               end if;
503
            end;
504
 
505
         --  Other attribute declarations (not full associative array)
506
 
507
         else
508
            declare
509
               Expression_Location : constant Source_Ptr := Token_Ptr;
510
               --  The location of the first token of the expression
511
 
512
               Expression          : Project_Node_Id     := Empty_Node;
513
               --  The expression, value for the attribute declaration
514
 
515
            begin
516
               --  Get the expression value and set it in the attribute node
517
 
518
               Parse_Expression
519
                 (In_Tree         => In_Tree,
520
                  Expression      => Expression,
521
                  Current_Project => Current_Project,
522
                  Current_Package => Current_Package,
523
                  Optional_Index  => Optional_Index);
524
               Set_Expression_Of (Attribute, In_Tree, To => Expression);
525
 
526
               --  If the expression is legal, but not of the right kind
527
               --  for the attribute, issue an error.
528
 
529
               if Current_Attribute /= Empty_Attribute
530
                 and then Expression /= Empty_Node
531
                 and then Variable_Kind_Of (Current_Attribute) /=
532
                 Expression_Kind_Of (Expression, In_Tree)
533
               then
534
                  if  Variable_Kind_Of (Current_Attribute) = Undefined then
535
                     Set_Variable_Kind_Of
536
                       (Current_Attribute,
537
                        To => Expression_Kind_Of (Expression, In_Tree));
538
 
539
                  else
540
                     Error_Msg
541
                       ("wrong expression kind for attribute """ &
542
                        Get_Name_String
543
                          (Attribute_Name_Of (Current_Attribute)) &
544
                        """",
545
                        Expression_Location);
546
                  end if;
547
               end if;
548
            end;
549
         end if;
550
      end if;
551
 
552
      --  If the attribute was not recognized, return an empty node.
553
      --  It may be that it is not in a package to check, and the node will
554
      --  not be added to the tree.
555
 
556
      if Current_Attribute = Empty_Attribute then
557
         Attribute := Empty_Node;
558
      end if;
559
 
560
      Set_End_Of_Line (Attribute);
561
      Set_Previous_Line_Node (Attribute);
562
   end Parse_Attribute_Declaration;
563
 
564
   -----------------------------
565
   -- Parse_Case_Construction --
566
   -----------------------------
567
 
568
   procedure Parse_Case_Construction
569
     (In_Tree           : Project_Node_Tree_Ref;
570
      Case_Construction : out Project_Node_Id;
571
      First_Attribute   : Attribute_Node_Id;
572
      Current_Project   : Project_Node_Id;
573
      Current_Package   : Project_Node_Id;
574
      Packages_To_Check : String_List_Access)
575
   is
576
      Current_Item    : Project_Node_Id := Empty_Node;
577
      Next_Item       : Project_Node_Id := Empty_Node;
578
      First_Case_Item : Boolean := True;
579
 
580
      Variable_Location : Source_Ptr := No_Location;
581
 
582
      String_Type : Project_Node_Id := Empty_Node;
583
 
584
      Case_Variable : Project_Node_Id := Empty_Node;
585
 
586
      First_Declarative_Item : Project_Node_Id := Empty_Node;
587
 
588
      First_Choice           : Project_Node_Id := Empty_Node;
589
 
590
      When_Others            : Boolean := False;
591
      --  Set to True when there is a "when others =>" clause
592
 
593
   begin
594
      Case_Construction  :=
595
        Default_Project_Node
596
          (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
597
      Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
598
 
599
      --  Scan past "case"
600
 
601
      Scan (In_Tree);
602
 
603
      --  Get the switch variable
604
 
605
      Expect (Tok_Identifier, "identifier");
606
 
607
      if Token = Tok_Identifier then
608
         Variable_Location := Token_Ptr;
609
         Parse_Variable_Reference
610
           (In_Tree         => In_Tree,
611
            Variable        => Case_Variable,
612
            Current_Project => Current_Project,
613
            Current_Package => Current_Package);
614
         Set_Case_Variable_Reference_Of
615
           (Case_Construction, In_Tree, To => Case_Variable);
616
 
617
      else
618
         if Token /= Tok_Is then
619
            Scan (In_Tree);
620
         end if;
621
      end if;
622
 
623
      if Case_Variable /= Empty_Node then
624
         String_Type := String_Type_Of (Case_Variable, In_Tree);
625
 
626
         if String_Type = Empty_Node then
627
            Error_Msg ("variable """ &
628
                       Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
629
                       """ is not typed",
630
                       Variable_Location);
631
         end if;
632
      end if;
633
 
634
      Expect (Tok_Is, "IS");
635
 
636
      if Token = Tok_Is then
637
         Set_End_Of_Line (Case_Construction);
638
         Set_Previous_Line_Node (Case_Construction);
639
         Set_Next_End_Node (Case_Construction);
640
 
641
         --  Scan past "is"
642
 
643
         Scan (In_Tree);
644
      end if;
645
 
646
      Start_New_Case_Construction (In_Tree, String_Type);
647
 
648
      When_Loop :
649
 
650
      while Token = Tok_When loop
651
 
652
         if First_Case_Item then
653
            Current_Item :=
654
              Default_Project_Node
655
                (Of_Kind => N_Case_Item, In_Tree => In_Tree);
656
            Set_First_Case_Item_Of
657
              (Case_Construction, In_Tree, To => Current_Item);
658
            First_Case_Item := False;
659
 
660
         else
661
            Next_Item :=
662
              Default_Project_Node
663
                (Of_Kind => N_Case_Item, In_Tree => In_Tree);
664
            Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
665
            Current_Item := Next_Item;
666
         end if;
667
 
668
         Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
669
 
670
         --  Scan past "when"
671
 
672
         Scan (In_Tree);
673
 
674
         if Token = Tok_Others then
675
            When_Others := True;
676
 
677
            --  Scan past "others"
678
 
679
            Scan (In_Tree);
680
 
681
            Expect (Tok_Arrow, "`=>`");
682
            Set_End_Of_Line (Current_Item);
683
            Set_Previous_Line_Node (Current_Item);
684
 
685
            --  Empty_Node in Field1 of a Case_Item indicates
686
            --  the "when others =>" branch.
687
 
688
            Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
689
 
690
            Parse_Declarative_Items
691
              (In_Tree           => In_Tree,
692
               Declarations      => First_Declarative_Item,
693
               In_Zone           => In_Case_Construction,
694
               First_Attribute   => First_Attribute,
695
               Current_Project   => Current_Project,
696
               Current_Package   => Current_Package,
697
               Packages_To_Check => Packages_To_Check);
698
 
699
            --  "when others =>" must be the last branch, so save the
700
            --  Case_Item and exit
701
 
702
            Set_First_Declarative_Item_Of
703
              (Current_Item, In_Tree, To => First_Declarative_Item);
704
            exit When_Loop;
705
 
706
         else
707
            Parse_Choice_List
708
              (In_Tree      => In_Tree,
709
               First_Choice => First_Choice);
710
            Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
711
 
712
            Expect (Tok_Arrow, "`=>`");
713
            Set_End_Of_Line (Current_Item);
714
            Set_Previous_Line_Node (Current_Item);
715
 
716
            Parse_Declarative_Items
717
              (In_Tree           => In_Tree,
718
               Declarations      => First_Declarative_Item,
719
               In_Zone           => In_Case_Construction,
720
               First_Attribute   => First_Attribute,
721
               Current_Project   => Current_Project,
722
               Current_Package   => Current_Package,
723
               Packages_To_Check => Packages_To_Check);
724
 
725
            Set_First_Declarative_Item_Of
726
              (Current_Item, In_Tree, To => First_Declarative_Item);
727
 
728
         end if;
729
      end loop When_Loop;
730
 
731
      End_Case_Construction
732
        (Check_All_Labels => not When_Others and not Quiet_Output,
733
         Case_Location    => Location_Of (Case_Construction, In_Tree));
734
 
735
      Expect (Tok_End, "`END CASE`");
736
      Remove_Next_End_Node;
737
 
738
      if Token = Tok_End then
739
 
740
         --  Scan past "end"
741
 
742
         Scan (In_Tree);
743
 
744
         Expect (Tok_Case, "CASE");
745
 
746
      end if;
747
 
748
      --  Scan past "case"
749
 
750
      Scan (In_Tree);
751
 
752
      Expect (Tok_Semicolon, "`;`");
753
      Set_Previous_End_Node (Case_Construction);
754
 
755
   end Parse_Case_Construction;
756
 
757
   -----------------------------
758
   -- Parse_Declarative_Items --
759
   -----------------------------
760
 
761
   procedure Parse_Declarative_Items
762
     (In_Tree           : Project_Node_Tree_Ref;
763
      Declarations      : out Project_Node_Id;
764
      In_Zone           : Zone;
765
      First_Attribute   : Attribute_Node_Id;
766
      Current_Project   : Project_Node_Id;
767
      Current_Package   : Project_Node_Id;
768
      Packages_To_Check : String_List_Access)
769
   is
770
      Current_Declarative_Item : Project_Node_Id := Empty_Node;
771
      Next_Declarative_Item    : Project_Node_Id := Empty_Node;
772
      Current_Declaration      : Project_Node_Id := Empty_Node;
773
      Item_Location            : Source_Ptr      := No_Location;
774
 
775
   begin
776
      Declarations := Empty_Node;
777
 
778
      loop
779
         --  We are always positioned at the token that precedes
780
         --  the first token of the declarative element.
781
         --  Scan past it
782
 
783
         Scan (In_Tree);
784
 
785
         Item_Location := Token_Ptr;
786
 
787
         case Token is
788
            when Tok_Identifier =>
789
 
790
               if In_Zone = In_Case_Construction then
791
                  Error_Msg ("a variable cannot be declared here",
792
                             Token_Ptr);
793
               end if;
794
 
795
               Parse_Variable_Declaration
796
                 (In_Tree,
797
                  Current_Declaration,
798
                  Current_Project => Current_Project,
799
                  Current_Package => Current_Package);
800
 
801
               Set_End_Of_Line (Current_Declaration);
802
               Set_Previous_Line_Node (Current_Declaration);
803
 
804
            when Tok_For =>
805
 
806
               Parse_Attribute_Declaration
807
                 (In_Tree           => In_Tree,
808
                  Attribute         => Current_Declaration,
809
                  First_Attribute   => First_Attribute,
810
                  Current_Project   => Current_Project,
811
                  Current_Package   => Current_Package,
812
                  Packages_To_Check => Packages_To_Check);
813
 
814
               Set_End_Of_Line (Current_Declaration);
815
               Set_Previous_Line_Node (Current_Declaration);
816
 
817
            when Tok_Null =>
818
 
819
               Scan (In_Tree); --  past "null"
820
 
821
            when Tok_Package =>
822
 
823
               --  Package declaration
824
 
825
               if In_Zone /= In_Project then
826
                  Error_Msg ("a package cannot be declared here", Token_Ptr);
827
               end if;
828
 
829
               Parse_Package_Declaration
830
                 (In_Tree             => In_Tree,
831
                  Package_Declaration => Current_Declaration,
832
                  Current_Project     => Current_Project,
833
                  Packages_To_Check   => Packages_To_Check);
834
 
835
               Set_Previous_End_Node (Current_Declaration);
836
 
837
            when Tok_Type =>
838
 
839
               --  Type String Declaration
840
 
841
               if In_Zone /= In_Project then
842
                  Error_Msg ("a string type cannot be declared here",
843
                             Token_Ptr);
844
               end if;
845
 
846
               Parse_String_Type_Declaration
847
                 (In_Tree         => In_Tree,
848
                  String_Type     => Current_Declaration,
849
                  Current_Project => Current_Project);
850
 
851
               Set_End_Of_Line (Current_Declaration);
852
               Set_Previous_Line_Node (Current_Declaration);
853
 
854
            when Tok_Case =>
855
 
856
               --  Case construction
857
 
858
               Parse_Case_Construction
859
                 (In_Tree           => In_Tree,
860
                  Case_Construction => Current_Declaration,
861
                  First_Attribute   => First_Attribute,
862
                  Current_Project   => Current_Project,
863
                  Current_Package   => Current_Package,
864
                  Packages_To_Check => Packages_To_Check);
865
 
866
               Set_Previous_End_Node (Current_Declaration);
867
 
868
            when others =>
869
               exit;
870
 
871
               --  We are leaving Parse_Declarative_Items positionned
872
               --  at the first token after the list of declarative items.
873
               --  It could be "end" (for a project, a package declaration or
874
               --  a case construction) or "when" (for a case construction)
875
 
876
         end case;
877
 
878
         Expect (Tok_Semicolon, "`;` after declarative items");
879
 
880
         --  Insert an N_Declarative_Item in the tree, but only if
881
         --  Current_Declaration is not an empty node.
882
 
883
         if Current_Declaration /= Empty_Node then
884
            if Current_Declarative_Item = Empty_Node then
885
               Current_Declarative_Item :=
886
                 Default_Project_Node
887
                   (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
888
               Declarations  := Current_Declarative_Item;
889
 
890
            else
891
               Next_Declarative_Item :=
892
                 Default_Project_Node
893
                   (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
894
               Set_Next_Declarative_Item
895
                 (Current_Declarative_Item, In_Tree,
896
                  To => Next_Declarative_Item);
897
               Current_Declarative_Item := Next_Declarative_Item;
898
            end if;
899
 
900
            Set_Current_Item_Node
901
              (Current_Declarative_Item, In_Tree,
902
               To => Current_Declaration);
903
            Set_Location_Of
904
              (Current_Declarative_Item, In_Tree, To => Item_Location);
905
         end if;
906
      end loop;
907
   end Parse_Declarative_Items;
908
 
909
   -------------------------------
910
   -- Parse_Package_Declaration --
911
   -------------------------------
912
 
913
   procedure Parse_Package_Declaration
914
     (In_Tree             : Project_Node_Tree_Ref;
915
      Package_Declaration : out Project_Node_Id;
916
      Current_Project     : Project_Node_Id;
917
      Packages_To_Check   : String_List_Access)
918
   is
919
      First_Attribute        : Attribute_Node_Id := Empty_Attribute;
920
      Current_Package        : Package_Node_Id   := Empty_Package;
921
      First_Declarative_Item : Project_Node_Id   := Empty_Node;
922
 
923
   begin
924
      Package_Declaration :=
925
        Default_Project_Node
926
          (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
927
      Set_Location_Of (Package_Declaration, In_Tree, To => Token_Ptr);
928
 
929
      --  Scan past "package"
930
 
931
      Scan (In_Tree);
932
      Expect (Tok_Identifier, "identifier");
933
 
934
      if Token = Tok_Identifier then
935
         Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
936
 
937
         Current_Package := Package_Node_Id_Of (Token_Name);
938
 
939
         if Current_Package  /= Empty_Package then
940
            First_Attribute := First_Attribute_Of (Current_Package);
941
 
942
         else
943
            Error_Msg ("?""" &
944
                       Get_Name_String
945
                         (Name_Of (Package_Declaration, In_Tree)) &
946
                       """ is not a known package name",
947
                       Token_Ptr);
948
 
949
            --  Set the package declaration to "ignored" so that it is not
950
            --  processed by Prj.Proc.Process.
951
 
952
            Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
953
 
954
            --  Add the unknown package in the list of packages
955
 
956
            Add_Unknown_Package (Token_Name, Current_Package);
957
         end if;
958
 
959
         Set_Package_Id_Of
960
           (Package_Declaration, In_Tree, To => Current_Package);
961
 
962
         declare
963
            Current : Project_Node_Id :=
964
                        First_Package_Of (Current_Project, In_Tree);
965
 
966
         begin
967
            while Current /= Empty_Node
968
              and then Name_Of (Current, In_Tree) /= Token_Name
969
            loop
970
               Current := Next_Package_In_Project (Current, In_Tree);
971
            end loop;
972
 
973
            if Current /= Empty_Node then
974
               Error_Msg
975
                 ("package """ &
976
                  Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
977
                  """ is declared twice in the same project",
978
                  Token_Ptr);
979
 
980
            else
981
               --  Add the package to the project list
982
 
983
               Set_Next_Package_In_Project
984
                 (Package_Declaration, In_Tree,
985
                  To => First_Package_Of (Current_Project, In_Tree));
986
               Set_First_Package_Of
987
                 (Current_Project, In_Tree, To => Package_Declaration);
988
            end if;
989
         end;
990
 
991
         --  Scan past the package name
992
 
993
         Scan (In_Tree);
994
      end if;
995
 
996
      if Token = Tok_Renames then
997
 
998
         --  Scan past "renames"
999
 
1000
         Scan (In_Tree);
1001
 
1002
         Expect (Tok_Identifier, "identifier");
1003
 
1004
         if Token = Tok_Identifier then
1005
            declare
1006
               Project_Name : constant Name_Id := Token_Name;
1007
               Clause       : Project_Node_Id :=
1008
                              First_With_Clause_Of (Current_Project, In_Tree);
1009
               The_Project  : Project_Node_Id := Empty_Node;
1010
               Extended     : constant Project_Node_Id :=
1011
                                Extended_Project_Of
1012
                                  (Project_Declaration_Of
1013
                                    (Current_Project, In_Tree),
1014
                                   In_Tree);
1015
            begin
1016
               while Clause /= Empty_Node loop
1017
                  --  Only non limited imported projects may be used in a
1018
                  --  renames declaration.
1019
 
1020
                  The_Project :=
1021
                    Non_Limited_Project_Node_Of (Clause, In_Tree);
1022
                  exit when The_Project /= Empty_Node
1023
                    and then Name_Of (The_Project, In_Tree) = Project_Name;
1024
                  Clause := Next_With_Clause_Of (Clause, In_Tree);
1025
               end loop;
1026
 
1027
               if Clause = Empty_Node then
1028
                  --  As we have not found the project in the imports, we check
1029
                  --  if it's the name of an eventual extended project.
1030
 
1031
                  if Extended /= Empty_Node
1032
                    and then Name_Of (Extended, In_Tree) = Project_Name
1033
                  then
1034
                     Set_Project_Of_Renamed_Package_Of
1035
                       (Package_Declaration, In_Tree, To => Extended);
1036
                  else
1037
                     Error_Msg_Name_1 := Project_Name;
1038
                     Error_Msg
1039
                       ("% is not an imported or extended project", Token_Ptr);
1040
                  end if;
1041
               else
1042
                  Set_Project_Of_Renamed_Package_Of
1043
                    (Package_Declaration, In_Tree, To => The_Project);
1044
               end if;
1045
            end;
1046
 
1047
            Scan (In_Tree);
1048
            Expect (Tok_Dot, "`.`");
1049
 
1050
            if Token = Tok_Dot then
1051
               Scan (In_Tree);
1052
               Expect (Tok_Identifier, "identifier");
1053
 
1054
               if Token = Tok_Identifier then
1055
                  if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1056
                     Error_Msg ("not the same package name", Token_Ptr);
1057
                  elsif
1058
                    Project_Of_Renamed_Package_Of
1059
                      (Package_Declaration, In_Tree) /= Empty_Node
1060
                  then
1061
                     declare
1062
                        Current : Project_Node_Id :=
1063
                                    First_Package_Of
1064
                                      (Project_Of_Renamed_Package_Of
1065
                                           (Package_Declaration, In_Tree),
1066
                                       In_Tree);
1067
 
1068
                     begin
1069
                        while Current /= Empty_Node
1070
                          and then Name_Of (Current, In_Tree) /= Token_Name
1071
                        loop
1072
                           Current :=
1073
                             Next_Package_In_Project (Current, In_Tree);
1074
                        end loop;
1075
 
1076
                        if Current = Empty_Node then
1077
                           Error_Msg
1078
                             ("""" &
1079
                              Get_Name_String (Token_Name) &
1080
                              """ is not a package declared by the project",
1081
                              Token_Ptr);
1082
                        end if;
1083
                     end;
1084
                  end if;
1085
 
1086
                  Scan (In_Tree);
1087
               end if;
1088
            end if;
1089
         end if;
1090
 
1091
         Expect (Tok_Semicolon, "`;`");
1092
         Set_End_Of_Line (Package_Declaration);
1093
         Set_Previous_Line_Node (Package_Declaration);
1094
 
1095
      elsif Token = Tok_Is then
1096
         Set_End_Of_Line (Package_Declaration);
1097
         Set_Previous_Line_Node (Package_Declaration);
1098
         Set_Next_End_Node (Package_Declaration);
1099
 
1100
         Parse_Declarative_Items
1101
           (In_Tree           => In_Tree,
1102
            Declarations      => First_Declarative_Item,
1103
            In_Zone           => In_Package,
1104
            First_Attribute   => First_Attribute,
1105
            Current_Project   => Current_Project,
1106
            Current_Package   => Package_Declaration,
1107
            Packages_To_Check => Packages_To_Check);
1108
 
1109
         Set_First_Declarative_Item_Of
1110
           (Package_Declaration, In_Tree, To => First_Declarative_Item);
1111
 
1112
         Expect (Tok_End, "END");
1113
 
1114
         if Token = Tok_End then
1115
 
1116
            --  Scan past "end"
1117
 
1118
            Scan (In_Tree);
1119
         end if;
1120
 
1121
         --  We should have the name of the package after "end"
1122
 
1123
         Expect (Tok_Identifier, "identifier");
1124
 
1125
         if Token = Tok_Identifier
1126
           and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1127
           and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1128
         then
1129
            Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1130
            Error_Msg ("expected {", Token_Ptr);
1131
         end if;
1132
 
1133
         if Token /= Tok_Semicolon then
1134
 
1135
            --  Scan past the package name
1136
 
1137
            Scan (In_Tree);
1138
         end if;
1139
 
1140
         Expect (Tok_Semicolon, "`;`");
1141
         Remove_Next_End_Node;
1142
 
1143
      else
1144
         Error_Msg ("expected IS or RENAMES", Token_Ptr);
1145
      end if;
1146
 
1147
   end Parse_Package_Declaration;
1148
 
1149
   -----------------------------------
1150
   -- Parse_String_Type_Declaration --
1151
   -----------------------------------
1152
 
1153
   procedure Parse_String_Type_Declaration
1154
     (In_Tree         : Project_Node_Tree_Ref;
1155
      String_Type     : out Project_Node_Id;
1156
      Current_Project : Project_Node_Id)
1157
   is
1158
      Current      : Project_Node_Id := Empty_Node;
1159
      First_String : Project_Node_Id := Empty_Node;
1160
 
1161
   begin
1162
      String_Type :=
1163
        Default_Project_Node
1164
          (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1165
 
1166
      Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1167
 
1168
      --  Scan past "type"
1169
 
1170
      Scan (In_Tree);
1171
 
1172
      Expect (Tok_Identifier, "identifier");
1173
 
1174
      if Token = Tok_Identifier then
1175
         Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1176
 
1177
         Current := First_String_Type_Of (Current_Project, In_Tree);
1178
         while Current /= Empty_Node
1179
           and then
1180
           Name_Of (Current, In_Tree) /= Token_Name
1181
         loop
1182
            Current := Next_String_Type (Current, In_Tree);
1183
         end loop;
1184
 
1185
         if Current /= Empty_Node then
1186
            Error_Msg ("duplicate string type name """ &
1187
                       Get_Name_String (Token_Name) &
1188
                       """",
1189
                       Token_Ptr);
1190
         else
1191
            Current := First_Variable_Of (Current_Project, In_Tree);
1192
            while Current /= Empty_Node
1193
              and then Name_Of (Current, In_Tree) /= Token_Name
1194
            loop
1195
               Current := Next_Variable (Current, In_Tree);
1196
            end loop;
1197
 
1198
            if Current /= Empty_Node then
1199
               Error_Msg ("""" &
1200
                          Get_Name_String (Token_Name) &
1201
                          """ is already a variable name", Token_Ptr);
1202
            else
1203
               Set_Next_String_Type
1204
                 (String_Type, In_Tree,
1205
                  To => First_String_Type_Of (Current_Project, In_Tree));
1206
               Set_First_String_Type_Of
1207
                 (Current_Project, In_Tree, To => String_Type);
1208
            end if;
1209
         end if;
1210
 
1211
         --  Scan past the name
1212
 
1213
         Scan (In_Tree);
1214
      end if;
1215
 
1216
      Expect (Tok_Is, "IS");
1217
 
1218
      if Token = Tok_Is then
1219
         Scan (In_Tree);
1220
      end if;
1221
 
1222
      Expect (Tok_Left_Paren, "`(`");
1223
 
1224
      if Token = Tok_Left_Paren then
1225
         Scan (In_Tree);
1226
      end if;
1227
 
1228
      Parse_String_Type_List
1229
        (In_Tree => In_Tree, First_String => First_String);
1230
      Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1231
 
1232
      Expect (Tok_Right_Paren, "`)`");
1233
 
1234
      if Token = Tok_Right_Paren then
1235
         Scan (In_Tree);
1236
      end if;
1237
 
1238
   end Parse_String_Type_Declaration;
1239
 
1240
   --------------------------------
1241
   -- Parse_Variable_Declaration --
1242
   --------------------------------
1243
 
1244
   procedure Parse_Variable_Declaration
1245
     (In_Tree         : Project_Node_Tree_Ref;
1246
      Variable        : out Project_Node_Id;
1247
      Current_Project : Project_Node_Id;
1248
      Current_Package : Project_Node_Id)
1249
   is
1250
      Expression_Location      : Source_Ptr;
1251
      String_Type_Name         : Name_Id := No_Name;
1252
      Project_String_Type_Name : Name_Id := No_Name;
1253
      Type_Location            : Source_Ptr := No_Location;
1254
      Project_Location         : Source_Ptr := No_Location;
1255
      Expression               : Project_Node_Id := Empty_Node;
1256
      Variable_Name            : constant Name_Id := Token_Name;
1257
      OK                       : Boolean := True;
1258
 
1259
   begin
1260
      Variable :=
1261
        Default_Project_Node
1262
          (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1263
      Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1264
      Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1265
 
1266
      --  Scan past the variable name
1267
 
1268
      Scan (In_Tree);
1269
 
1270
      if Token = Tok_Colon then
1271
 
1272
         --  Typed string variable declaration
1273
 
1274
         Scan (In_Tree);
1275
         Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1276
         Expect (Tok_Identifier, "identifier");
1277
 
1278
         OK := Token = Tok_Identifier;
1279
 
1280
         if OK then
1281
            String_Type_Name := Token_Name;
1282
            Type_Location := Token_Ptr;
1283
            Scan (In_Tree);
1284
 
1285
            if Token = Tok_Dot then
1286
               Project_String_Type_Name := String_Type_Name;
1287
               Project_Location := Type_Location;
1288
 
1289
               --  Scan past the dot
1290
 
1291
               Scan (In_Tree);
1292
               Expect (Tok_Identifier, "identifier");
1293
 
1294
               if Token = Tok_Identifier then
1295
                  String_Type_Name := Token_Name;
1296
                  Type_Location := Token_Ptr;
1297
                  Scan (In_Tree);
1298
               else
1299
                  OK := False;
1300
               end if;
1301
            end if;
1302
 
1303
            if OK then
1304
               declare
1305
                  Current : Project_Node_Id :=
1306
                              First_String_Type_Of (Current_Project, In_Tree);
1307
 
1308
               begin
1309
                  if Project_String_Type_Name /= No_Name then
1310
                     declare
1311
                        The_Project_Name_And_Node : constant
1312
                          Tree_Private_Part.Project_Name_And_Node :=
1313
                          Tree_Private_Part.Projects_Htable.Get
1314
                            (In_Tree.Projects_HT, Project_String_Type_Name);
1315
 
1316
                        use Tree_Private_Part;
1317
 
1318
                     begin
1319
                        if The_Project_Name_And_Node =
1320
                          Tree_Private_Part.No_Project_Name_And_Node
1321
                        then
1322
                           Error_Msg ("unknown project """ &
1323
                                      Get_Name_String
1324
                                         (Project_String_Type_Name) &
1325
                                      """",
1326
                                      Project_Location);
1327
                           Current := Empty_Node;
1328
                        else
1329
                           Current :=
1330
                             First_String_Type_Of
1331
                               (The_Project_Name_And_Node.Node, In_Tree);
1332
                        end if;
1333
                     end;
1334
                  end if;
1335
 
1336
                  while Current /= Empty_Node
1337
                    and then Name_Of (Current, In_Tree) /= String_Type_Name
1338
                  loop
1339
                     Current := Next_String_Type (Current, In_Tree);
1340
                  end loop;
1341
 
1342
                  if Current = Empty_Node then
1343
                     Error_Msg ("unknown string type """ &
1344
                                Get_Name_String (String_Type_Name) &
1345
                                """",
1346
                                Type_Location);
1347
                     OK := False;
1348
                  else
1349
                     Set_String_Type_Of
1350
                       (Variable, In_Tree, To => Current);
1351
                  end if;
1352
               end;
1353
            end if;
1354
         end if;
1355
      end if;
1356
 
1357
      Expect (Tok_Colon_Equal, "`:=`");
1358
 
1359
      OK := OK and (Token = Tok_Colon_Equal);
1360
 
1361
      if Token = Tok_Colon_Equal then
1362
         Scan (In_Tree);
1363
      end if;
1364
 
1365
      --  Get the single string or string list value
1366
 
1367
      Expression_Location := Token_Ptr;
1368
 
1369
      Parse_Expression
1370
        (In_Tree         => In_Tree,
1371
         Expression      => Expression,
1372
         Current_Project => Current_Project,
1373
         Current_Package => Current_Package,
1374
         Optional_Index  => False);
1375
      Set_Expression_Of (Variable, In_Tree, To => Expression);
1376
 
1377
      if Expression /= Empty_Node then
1378
         --  A typed string must have a single string value, not a list
1379
 
1380
         if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1381
           and then Expression_Kind_Of (Expression, In_Tree) = List
1382
         then
1383
            Error_Msg
1384
              ("expression must be a single string", Expression_Location);
1385
         end if;
1386
 
1387
         Set_Expression_Kind_Of
1388
           (Variable, In_Tree,
1389
            To => Expression_Kind_Of (Expression, In_Tree));
1390
      end if;
1391
 
1392
      if OK then
1393
         declare
1394
            The_Variable : Project_Node_Id := Empty_Node;
1395
 
1396
         begin
1397
            if Current_Package /= Empty_Node then
1398
               The_Variable := First_Variable_Of (Current_Package, In_Tree);
1399
            elsif Current_Project /= Empty_Node then
1400
               The_Variable :=  First_Variable_Of (Current_Project, In_Tree);
1401
            end if;
1402
 
1403
            while The_Variable /= Empty_Node
1404
              and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1405
            loop
1406
               The_Variable := Next_Variable (The_Variable, In_Tree);
1407
            end loop;
1408
 
1409
            if The_Variable = Empty_Node then
1410
               if Current_Package /= Empty_Node then
1411
                  Set_Next_Variable
1412
                    (Variable, In_Tree,
1413
                     To => First_Variable_Of (Current_Package, In_Tree));
1414
                  Set_First_Variable_Of
1415
                    (Current_Package, In_Tree, To => Variable);
1416
 
1417
               elsif Current_Project /= Empty_Node then
1418
                  Set_Next_Variable
1419
                    (Variable, In_Tree,
1420
                     To => First_Variable_Of (Current_Project, In_Tree));
1421
                  Set_First_Variable_Of
1422
                    (Current_Project, In_Tree, To => Variable);
1423
               end if;
1424
 
1425
            else
1426
               if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1427
                  if
1428
                    Expression_Kind_Of (The_Variable, In_Tree) = Undefined
1429
                  then
1430
                     Set_Expression_Kind_Of
1431
                       (The_Variable, In_Tree,
1432
                        To => Expression_Kind_Of (Variable, In_Tree));
1433
 
1434
                  else
1435
                     if Expression_Kind_Of (The_Variable, In_Tree) /=
1436
                       Expression_Kind_Of (Variable, In_Tree)
1437
                     then
1438
                        Error_Msg ("wrong expression kind for variable """ &
1439
                                   Get_Name_String
1440
                                     (Name_Of (The_Variable, In_Tree)) &
1441
                                     """",
1442
                                   Expression_Location);
1443
                     end if;
1444
                  end if;
1445
               end if;
1446
            end if;
1447
         end;
1448
      end if;
1449
 
1450
   end Parse_Variable_Declaration;
1451
 
1452
end Prj.Dect;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.