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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_aux.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ A U X                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- As a special exception,  if other files  instantiate  generics from this --
22
-- unit, or you link  this unit with other files  to produce an executable, --
23
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
24
-- covered  by the  GNU  General  Public  License.  This exception does not --
25
-- however invalidate  any other reasons why  the executable file  might be --
26
-- covered by the  GNU Public License.                                      --
27
--                                                                          --
28
-- GNAT was originally developed  by the GNAT team at  New York University. --
29
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
30
--                                                                          --
31
------------------------------------------------------------------------------
32
 
33
with Atree;  use Atree;
34
with Einfo;  use Einfo;
35
with Namet;  use Namet;
36
with Sinfo;  use Sinfo;
37
with Snames; use Snames;
38
with Stand;  use Stand;
39
 
40
package body Sem_Aux is
41
 
42
   ----------------------
43
   -- Ancestor_Subtype --
44
   ----------------------
45
 
46
   function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
47
   begin
48
      --  If this is first subtype, or is a base type, then there is no
49
      --  ancestor subtype, so we return Empty to indicate this fact.
50
 
51
      if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
52
         return Empty;
53
      end if;
54
 
55
      declare
56
         D : constant Node_Id := Declaration_Node (Typ);
57
 
58
      begin
59
         --  If we have a subtype declaration, get the ancestor subtype
60
 
61
         if Nkind (D) = N_Subtype_Declaration then
62
            if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
63
               return Entity (Subtype_Mark (Subtype_Indication (D)));
64
            else
65
               return Entity (Subtype_Indication (D));
66
            end if;
67
 
68
         --  If not, then no subtype indication is available
69
 
70
         else
71
            return Empty;
72
         end if;
73
      end;
74
   end Ancestor_Subtype;
75
 
76
   --------------------
77
   -- Available_View --
78
   --------------------
79
 
80
   function Available_View (Typ : Entity_Id) return Entity_Id is
81
   begin
82
      if Is_Incomplete_Type (Typ)
83
        and then Present (Non_Limited_View (Typ))
84
      then
85
         --  The non-limited view may itself be an incomplete type, in which
86
         --  case get its full view.
87
 
88
         return Get_Full_View (Non_Limited_View (Typ));
89
 
90
      elsif Is_Class_Wide_Type (Typ)
91
        and then Is_Incomplete_Type (Etype (Typ))
92
        and then Present (Non_Limited_View (Etype (Typ)))
93
      then
94
         return Class_Wide_Type (Non_Limited_View (Etype (Typ)));
95
 
96
      else
97
         return Typ;
98
      end if;
99
   end Available_View;
100
 
101
   --------------------
102
   -- Constant_Value --
103
   --------------------
104
 
105
   function Constant_Value (Ent : Entity_Id) return Node_Id is
106
      D      : constant Node_Id := Declaration_Node (Ent);
107
      Full_D : Node_Id;
108
 
109
   begin
110
      --  If we have no declaration node, then return no constant value. Not
111
      --  clear how this can happen, but it does sometimes and this is the
112
      --  safest approach.
113
 
114
      if No (D) then
115
         return Empty;
116
 
117
      --  Normal case where a declaration node is present
118
 
119
      elsif Nkind (D) = N_Object_Renaming_Declaration then
120
         return Renamed_Object (Ent);
121
 
122
      --  If this is a component declaration whose entity is a constant, it is
123
      --  a prival within a protected function (and so has no constant value).
124
 
125
      elsif Nkind (D) = N_Component_Declaration then
126
         return Empty;
127
 
128
      --  If there is an expression, return it
129
 
130
      elsif Present (Expression (D)) then
131
         return (Expression (D));
132
 
133
      --  For a constant, see if we have a full view
134
 
135
      elsif Ekind (Ent) = E_Constant
136
        and then Present (Full_View (Ent))
137
      then
138
         Full_D := Parent (Full_View (Ent));
139
 
140
         --  The full view may have been rewritten as an object renaming
141
 
142
         if Nkind (Full_D) = N_Object_Renaming_Declaration then
143
            return Name (Full_D);
144
         else
145
            return Expression (Full_D);
146
         end if;
147
 
148
      --  Otherwise we have no expression to return
149
 
150
      else
151
         return Empty;
152
      end if;
153
   end Constant_Value;
154
 
155
   ----------------------------------------------
156
   -- Effectively_Has_Constrained_Partial_View --
157
   ----------------------------------------------
158
 
159
   function Effectively_Has_Constrained_Partial_View
160
     (Typ  : Entity_Id;
161
      Scop : Entity_Id) return Boolean
162
   is
163
   begin
164
      return Has_Constrained_Partial_View (Typ)
165
        or else (In_Generic_Body (Scop)
166
                   and then Is_Generic_Type (Base_Type (Typ))
167
                   and then Is_Private_Type (Base_Type (Typ))
168
                   and then not Is_Tagged_Type (Typ)
169
                   and then not (Is_Array_Type (Typ)
170
                                   and then not Is_Constrained (Typ))
171
                   and then Has_Discriminants (Typ));
172
   end Effectively_Has_Constrained_Partial_View;
173
 
174
   -----------------------------
175
   -- Enclosing_Dynamic_Scope --
176
   -----------------------------
177
 
178
   function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
179
      S : Entity_Id;
180
 
181
   begin
182
      --  The following test is an error defense against some syntax errors
183
      --  that can leave scopes very messed up.
184
 
185
      if Ent = Standard_Standard then
186
         return Ent;
187
      end if;
188
 
189
      --  Normal case, search enclosing scopes
190
 
191
      --  Note: the test for Present (S) should not be required, it defends
192
      --  against an ill-formed tree.
193
 
194
      S := Scope (Ent);
195
      loop
196
         --  If we somehow got an empty value for Scope, the tree must be
197
         --  malformed. Rather than blow up we return Standard in this case.
198
 
199
         if No (S) then
200
            return Standard_Standard;
201
 
202
         --  Quit if we get to standard or a dynamic scope. We must also
203
         --  handle enclosing scopes that have a full view; required to
204
         --  locate enclosing scopes that are synchronized private types
205
         --  whose full view is a task type.
206
 
207
         elsif S = Standard_Standard
208
           or else Is_Dynamic_Scope (S)
209
           or else (Is_Private_Type (S)
210
                     and then Present (Full_View (S))
211
                     and then Is_Dynamic_Scope (Full_View (S)))
212
         then
213
            return S;
214
 
215
         --  Otherwise keep climbing
216
 
217
         else
218
            S := Scope (S);
219
         end if;
220
      end loop;
221
   end Enclosing_Dynamic_Scope;
222
 
223
   ------------------------
224
   -- First_Discriminant --
225
   ------------------------
226
 
227
   function First_Discriminant (Typ : Entity_Id) return Entity_Id is
228
      Ent : Entity_Id;
229
 
230
   begin
231
      pragma Assert
232
        (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));
233
 
234
      Ent := First_Entity (Typ);
235
 
236
      --  The discriminants are not necessarily contiguous, because access
237
      --  discriminants will generate itypes. They are not the first entities
238
      --  either because the tag must be ahead of them.
239
 
240
      if Chars (Ent) = Name_uTag then
241
         Ent := Next_Entity (Ent);
242
      end if;
243
 
244
      --  Skip all hidden stored discriminants if any
245
 
246
      while Present (Ent) loop
247
         exit when Ekind (Ent) = E_Discriminant
248
           and then not Is_Completely_Hidden (Ent);
249
 
250
         Ent := Next_Entity (Ent);
251
      end loop;
252
 
253
      pragma Assert (Ekind (Ent) = E_Discriminant);
254
 
255
      return Ent;
256
   end First_Discriminant;
257
 
258
   -------------------------------
259
   -- First_Stored_Discriminant --
260
   -------------------------------
261
 
262
   function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
263
      Ent : Entity_Id;
264
 
265
      function Has_Completely_Hidden_Discriminant
266
        (Typ : Entity_Id) return Boolean;
267
      --  Scans the Discriminants to see whether any are Completely_Hidden
268
      --  (the mechanism for describing non-specified stored discriminants)
269
 
270
      ----------------------------------------
271
      -- Has_Completely_Hidden_Discriminant --
272
      ----------------------------------------
273
 
274
      function Has_Completely_Hidden_Discriminant
275
        (Typ : Entity_Id) return Boolean
276
      is
277
         Ent : Entity_Id;
278
 
279
      begin
280
         pragma Assert (Ekind (Typ) = E_Discriminant);
281
 
282
         Ent := Typ;
283
         while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
284
            if Is_Completely_Hidden (Ent) then
285
               return True;
286
            end if;
287
 
288
            Ent := Next_Entity (Ent);
289
         end loop;
290
 
291
         return False;
292
      end Has_Completely_Hidden_Discriminant;
293
 
294
   --  Start of processing for First_Stored_Discriminant
295
 
296
   begin
297
      pragma Assert
298
        (Has_Discriminants (Typ)
299
          or else Has_Unknown_Discriminants (Typ));
300
 
301
      Ent := First_Entity (Typ);
302
 
303
      if Chars (Ent) = Name_uTag then
304
         Ent := Next_Entity (Ent);
305
      end if;
306
 
307
      if Has_Completely_Hidden_Discriminant (Ent) then
308
         while Present (Ent) loop
309
            exit when Is_Completely_Hidden (Ent);
310
            Ent := Next_Entity (Ent);
311
         end loop;
312
      end if;
313
 
314
      pragma Assert (Ekind (Ent) = E_Discriminant);
315
 
316
      return Ent;
317
   end First_Stored_Discriminant;
318
 
319
   -------------------
320
   -- First_Subtype --
321
   -------------------
322
 
323
   function First_Subtype (Typ : Entity_Id) return Entity_Id is
324
      B   : constant Entity_Id := Base_Type (Typ);
325
      F   : constant Node_Id   := Freeze_Node (B);
326
      Ent : Entity_Id;
327
 
328
   begin
329
      --  If the base type has no freeze node, it is a type in Standard, and
330
      --  always acts as its own first subtype, except where it is one of the
331
      --  predefined integer types. If the type is formal, it is also a first
332
      --  subtype, and its base type has no freeze node. On the other hand, a
333
      --  subtype of a generic formal is not its own first subtype. Its base
334
      --  type, if anonymous, is attached to the formal type decl. from which
335
      --  the first subtype is obtained.
336
 
337
      if No (F) then
338
         if B = Base_Type (Standard_Integer) then
339
            return Standard_Integer;
340
 
341
         elsif B = Base_Type (Standard_Long_Integer) then
342
            return Standard_Long_Integer;
343
 
344
         elsif B = Base_Type (Standard_Short_Short_Integer) then
345
            return Standard_Short_Short_Integer;
346
 
347
         elsif B = Base_Type (Standard_Short_Integer) then
348
            return Standard_Short_Integer;
349
 
350
         elsif B = Base_Type (Standard_Long_Long_Integer) then
351
            return Standard_Long_Long_Integer;
352
 
353
         elsif Is_Generic_Type (Typ) then
354
            if Present (Parent (B)) then
355
               return Defining_Identifier (Parent (B));
356
            else
357
               return Defining_Identifier (Associated_Node_For_Itype (B));
358
            end if;
359
 
360
         else
361
            return B;
362
         end if;
363
 
364
      --  Otherwise we check the freeze node, if it has a First_Subtype_Link
365
      --  then we use that link, otherwise (happens with some Itypes), we use
366
      --  the base type itself.
367
 
368
      else
369
         Ent := First_Subtype_Link (F);
370
 
371
         if Present (Ent) then
372
            return Ent;
373
         else
374
            return B;
375
         end if;
376
      end if;
377
   end First_Subtype;
378
 
379
   -------------------------
380
   -- First_Tag_Component --
381
   -------------------------
382
 
383
   function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
384
      Comp : Entity_Id;
385
      Ctyp : Entity_Id;
386
 
387
   begin
388
      Ctyp := Typ;
389
      pragma Assert (Is_Tagged_Type (Ctyp));
390
 
391
      if Is_Class_Wide_Type (Ctyp) then
392
         Ctyp := Root_Type (Ctyp);
393
      end if;
394
 
395
      if Is_Private_Type (Ctyp) then
396
         Ctyp := Underlying_Type (Ctyp);
397
 
398
         --  If the underlying type is missing then the source program has
399
         --  errors and there is nothing else to do (the full-type declaration
400
         --  associated with the private type declaration is missing).
401
 
402
         if No (Ctyp) then
403
            return Empty;
404
         end if;
405
      end if;
406
 
407
      Comp := First_Entity (Ctyp);
408
      while Present (Comp) loop
409
         if Is_Tag (Comp) then
410
            return Comp;
411
         end if;
412
 
413
         Comp := Next_Entity (Comp);
414
      end loop;
415
 
416
      --  No tag component found
417
 
418
      return Empty;
419
   end First_Tag_Component;
420
 
421
   -------------------------------
422
   -- Initialization_Suppressed --
423
   -------------------------------
424
 
425
   function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
426
   begin
427
      return Suppress_Initialization (Typ)
428
        or else Suppress_Initialization (Base_Type (Typ));
429
   end Initialization_Suppressed;
430
 
431
   ----------------
432
   -- Initialize --
433
   ----------------
434
 
435
   procedure Initialize is
436
   begin
437
      Obsolescent_Warnings.Init;
438
   end Initialize;
439
 
440
   ---------------------
441
   -- In_Generic_Body --
442
   ---------------------
443
 
444
   function In_Generic_Body (Id : Entity_Id) return Boolean is
445
      S : Entity_Id;
446
 
447
   begin
448
      --  Climb scopes looking for generic body
449
 
450
      S := Id;
451
      while Present (S) and then S /= Standard_Standard loop
452
 
453
         --  Generic package body
454
 
455
         if Ekind (S) = E_Generic_Package
456
           and then In_Package_Body (S)
457
         then
458
            return True;
459
 
460
         --  Generic subprogram body
461
 
462
         elsif Is_Subprogram (S)
463
           and then Nkind (Unit_Declaration_Node (S))
464
                      = N_Generic_Subprogram_Declaration
465
         then
466
            return True;
467
         end if;
468
 
469
         S := Scope (S);
470
      end loop;
471
 
472
      --  False if top of scope stack without finding a generic body
473
 
474
      return False;
475
   end In_Generic_Body;
476
 
477
   ---------------------
478
   -- Is_By_Copy_Type --
479
   ---------------------
480
 
481
   function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
482
   begin
483
      --  If Id is a private type whose full declaration has not been seen,
484
      --  we assume for now that it is not a By_Copy type. Clearly this
485
      --  attribute should not be used before the type is frozen, but it is
486
      --  needed to build the associated record of a protected type. Another
487
      --  place where some lookahead for a full view is needed ???
488
 
489
      return
490
        Is_Elementary_Type (Ent)
491
          or else (Is_Private_Type (Ent)
492
                     and then Present (Underlying_Type (Ent))
493
                     and then Is_Elementary_Type (Underlying_Type (Ent)));
494
   end Is_By_Copy_Type;
495
 
496
   --------------------------
497
   -- Is_By_Reference_Type --
498
   --------------------------
499
 
500
   function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
501
      Btype : constant Entity_Id := Base_Type (Ent);
502
 
503
   begin
504
      if Error_Posted (Ent) or else Error_Posted (Btype) then
505
         return False;
506
 
507
      elsif Is_Private_Type (Btype) then
508
         declare
509
            Utyp : constant Entity_Id := Underlying_Type (Btype);
510
         begin
511
            if No (Utyp) then
512
               return False;
513
            else
514
               return Is_By_Reference_Type (Utyp);
515
            end if;
516
         end;
517
 
518
      elsif Is_Incomplete_Type (Btype) then
519
         declare
520
            Ftyp : constant Entity_Id := Full_View (Btype);
521
         begin
522
            if No (Ftyp) then
523
               return False;
524
            else
525
               return Is_By_Reference_Type (Ftyp);
526
            end if;
527
         end;
528
 
529
      elsif Is_Concurrent_Type (Btype) then
530
         return True;
531
 
532
      elsif Is_Record_Type (Btype) then
533
         if Is_Limited_Record (Btype)
534
           or else Is_Tagged_Type (Btype)
535
           or else Is_Volatile (Btype)
536
         then
537
            return True;
538
 
539
         else
540
            declare
541
               C : Entity_Id;
542
 
543
            begin
544
               C := First_Component (Btype);
545
               while Present (C) loop
546
                  if Is_By_Reference_Type (Etype (C))
547
                    or else Is_Volatile (Etype (C))
548
                  then
549
                     return True;
550
                  end if;
551
 
552
                  C := Next_Component (C);
553
               end loop;
554
            end;
555
 
556
            return False;
557
         end if;
558
 
559
      elsif Is_Array_Type (Btype) then
560
         return
561
           Is_Volatile (Btype)
562
             or else Is_By_Reference_Type (Component_Type (Btype))
563
             or else Is_Volatile (Component_Type (Btype))
564
             or else Has_Volatile_Components (Btype);
565
 
566
      else
567
         return False;
568
      end if;
569
   end Is_By_Reference_Type;
570
 
571
   ---------------------
572
   -- Is_Derived_Type --
573
   ---------------------
574
 
575
   function Is_Derived_Type (Ent : E) return B is
576
      Par : Node_Id;
577
 
578
   begin
579
      if Is_Type (Ent)
580
        and then Base_Type (Ent) /= Root_Type (Ent)
581
        and then not Is_Class_Wide_Type (Ent)
582
      then
583
         if not Is_Numeric_Type (Root_Type (Ent)) then
584
            return True;
585
 
586
         else
587
            Par := Parent (First_Subtype (Ent));
588
 
589
            return Present (Par)
590
              and then Nkind (Par) = N_Full_Type_Declaration
591
              and then Nkind (Type_Definition (Par)) =
592
                         N_Derived_Type_Definition;
593
         end if;
594
 
595
      else
596
         return False;
597
      end if;
598
   end Is_Derived_Type;
599
 
600
   -----------------------
601
   -- Is_Generic_Formal --
602
   -----------------------
603
 
604
   function Is_Generic_Formal (E : Entity_Id) return Boolean is
605
      Kind : Node_Kind;
606
   begin
607
      if No (E) then
608
         return False;
609
      else
610
         Kind := Nkind (Parent (E));
611
         return
612
           Nkind_In (Kind, N_Formal_Object_Declaration,
613
                           N_Formal_Package_Declaration,
614
                           N_Formal_Type_Declaration)
615
             or else Is_Formal_Subprogram (E);
616
      end if;
617
   end Is_Generic_Formal;
618
 
619
   ---------------------------
620
   -- Is_Indefinite_Subtype --
621
   ---------------------------
622
 
623
   function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
624
      K : constant Entity_Kind := Ekind (Ent);
625
 
626
   begin
627
      if Is_Constrained (Ent) then
628
         return False;
629
 
630
      elsif K in Array_Kind
631
        or else K in Class_Wide_Kind
632
        or else Has_Unknown_Discriminants (Ent)
633
      then
634
         return True;
635
 
636
      --  Known discriminants: indefinite if there are no default values
637
 
638
      elsif K in Record_Kind
639
        or else Is_Incomplete_Or_Private_Type (Ent)
640
        or else Is_Concurrent_Type (Ent)
641
      then
642
         return (Has_Discriminants (Ent)
643
           and then
644
             No (Discriminant_Default_Value (First_Discriminant (Ent))));
645
 
646
      else
647
         return False;
648
      end if;
649
   end Is_Indefinite_Subtype;
650
 
651
   -------------------------------
652
   -- Is_Immutably_Limited_Type --
653
   -------------------------------
654
 
655
   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
656
      Btype : constant Entity_Id := Available_View (Base_Type (Ent));
657
 
658
   begin
659
      if Is_Limited_Record (Btype) then
660
         return True;
661
 
662
      elsif Ekind (Btype) = E_Limited_Private_Type
663
        and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
664
      then
665
         return not In_Package_Body (Scope ((Btype)));
666
 
667
      elsif Is_Private_Type (Btype) then
668
 
669
         --  AI05-0063: A type derived from a limited private formal type is
670
         --  not immutably limited in a generic body.
671
 
672
         if Is_Derived_Type (Btype)
673
           and then Is_Generic_Type (Etype (Btype))
674
         then
675
            if not Is_Limited_Type (Etype (Btype)) then
676
               return False;
677
 
678
            --  A descendant of a limited formal type is not immutably limited
679
            --  in the generic body, or in the body of a generic child.
680
 
681
            elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
682
               return not In_Package_Body (Scope (Btype));
683
 
684
            else
685
               return False;
686
            end if;
687
 
688
         else
689
            declare
690
               Utyp : constant Entity_Id := Underlying_Type (Btype);
691
            begin
692
               if No (Utyp) then
693
                  return False;
694
               else
695
                  return Is_Immutably_Limited_Type (Utyp);
696
               end if;
697
            end;
698
         end if;
699
 
700
      elsif Is_Concurrent_Type (Btype) then
701
         return True;
702
 
703
      elsif Is_Record_Type (Btype) then
704
 
705
         --  Note that we return True for all limited interfaces, even though
706
         --  (unsynchronized) limited interfaces can have descendants that are
707
         --  nonlimited, because this is a predicate on the type itself, and
708
         --  things like functions with limited interface results need to be
709
         --  handled as build in place even though they might return objects
710
         --  of a type that is not inherently limited.
711
 
712
         if Is_Class_Wide_Type (Btype) then
713
            return Is_Immutably_Limited_Type (Root_Type (Btype));
714
 
715
         else
716
            declare
717
               C : Entity_Id;
718
 
719
            begin
720
               C := First_Component (Btype);
721
               while Present (C) loop
722
 
723
                  --  Don't consider components with interface types (which can
724
                  --  only occur in the case of a _parent component anyway).
725
                  --  They don't have any components, plus it would cause this
726
                  --  function to return true for nonlimited types derived from
727
                  --  limited interfaces.
728
 
729
                  if not Is_Interface (Etype (C))
730
                    and then Is_Immutably_Limited_Type (Etype (C))
731
                  then
732
                     return True;
733
                  end if;
734
 
735
                  C := Next_Component (C);
736
               end loop;
737
            end;
738
 
739
            return False;
740
         end if;
741
 
742
      elsif Is_Array_Type (Btype) then
743
         return Is_Immutably_Limited_Type (Component_Type (Btype));
744
 
745
      else
746
         return False;
747
      end if;
748
   end Is_Immutably_Limited_Type;
749
 
750
   ---------------------
751
   -- Is_Limited_Type --
752
   ---------------------
753
 
754
   function Is_Limited_Type (Ent : Entity_Id) return Boolean is
755
      Btype : constant E := Base_Type (Ent);
756
      Rtype : constant E := Root_Type (Btype);
757
 
758
   begin
759
      if not Is_Type (Ent) then
760
         return False;
761
 
762
      elsif Ekind (Btype) = E_Limited_Private_Type
763
        or else Is_Limited_Composite (Btype)
764
      then
765
         return True;
766
 
767
      elsif Is_Concurrent_Type (Btype) then
768
         return True;
769
 
770
         --  The Is_Limited_Record flag normally indicates that the type is
771
         --  limited. The exception is that a type does not inherit limitedness
772
         --  from its interface ancestor. So the type may be derived from a
773
         --  limited interface, but is not limited.
774
 
775
      elsif Is_Limited_Record (Ent)
776
        and then not Is_Interface (Ent)
777
      then
778
         return True;
779
 
780
      --  Otherwise we will look around to see if there is some other reason
781
      --  for it to be limited, except that if an error was posted on the
782
      --  entity, then just assume it is non-limited, because it can cause
783
      --  trouble to recurse into a murky erroneous entity!
784
 
785
      elsif Error_Posted (Ent) then
786
         return False;
787
 
788
      elsif Is_Record_Type (Btype) then
789
 
790
         if Is_Limited_Interface (Ent) then
791
            return True;
792
 
793
         --  AI-419: limitedness is not inherited from a limited interface
794
 
795
         elsif Is_Limited_Record (Rtype) then
796
            return not Is_Interface (Rtype)
797
              or else Is_Protected_Interface (Rtype)
798
              or else Is_Synchronized_Interface (Rtype)
799
              or else Is_Task_Interface (Rtype);
800
 
801
         elsif Is_Class_Wide_Type (Btype) then
802
            return Is_Limited_Type (Rtype);
803
 
804
         else
805
            declare
806
               C : E;
807
 
808
            begin
809
               C := First_Component (Btype);
810
               while Present (C) loop
811
                  if Is_Limited_Type (Etype (C)) then
812
                     return True;
813
                  end if;
814
 
815
                  C := Next_Component (C);
816
               end loop;
817
            end;
818
 
819
            return False;
820
         end if;
821
 
822
      elsif Is_Array_Type (Btype) then
823
         return Is_Limited_Type (Component_Type (Btype));
824
 
825
      else
826
         return False;
827
      end if;
828
   end Is_Limited_Type;
829
 
830
   ----------------------
831
   -- Nearest_Ancestor --
832
   ----------------------
833
 
834
   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
835
         D : constant Node_Id := Declaration_Node (Typ);
836
 
837
   begin
838
      --  If we have a subtype declaration, get the ancestor subtype
839
 
840
      if Nkind (D) = N_Subtype_Declaration then
841
         if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
842
            return Entity (Subtype_Mark (Subtype_Indication (D)));
843
         else
844
            return Entity (Subtype_Indication (D));
845
         end if;
846
 
847
      --  If derived type declaration, find who we are derived from
848
 
849
      elsif Nkind (D) = N_Full_Type_Declaration
850
        and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
851
      then
852
         declare
853
            DTD : constant Entity_Id := Type_Definition (D);
854
            SI  : constant Entity_Id := Subtype_Indication (DTD);
855
         begin
856
            if Is_Entity_Name (SI) then
857
               return Entity (SI);
858
            else
859
               return Entity (Subtype_Mark (SI));
860
            end if;
861
         end;
862
 
863
      --  Otherwise, nothing useful to return, return Empty
864
 
865
      else
866
         return Empty;
867
      end if;
868
   end Nearest_Ancestor;
869
 
870
   ---------------------------
871
   -- Nearest_Dynamic_Scope --
872
   ---------------------------
873
 
874
   function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
875
   begin
876
      if Is_Dynamic_Scope (Ent) then
877
         return Ent;
878
      else
879
         return Enclosing_Dynamic_Scope (Ent);
880
      end if;
881
   end Nearest_Dynamic_Scope;
882
 
883
   ------------------------
884
   -- Next_Tag_Component --
885
   ------------------------
886
 
887
   function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
888
      Comp : Entity_Id;
889
 
890
   begin
891
      pragma Assert (Is_Tag (Tag));
892
 
893
      --  Loop to look for next tag component
894
 
895
      Comp := Next_Entity (Tag);
896
      while Present (Comp) loop
897
         if Is_Tag (Comp) then
898
            pragma Assert (Chars (Comp) /= Name_uTag);
899
            return Comp;
900
         end if;
901
 
902
         Comp := Next_Entity (Comp);
903
      end loop;
904
 
905
      --  No tag component found
906
 
907
      return Empty;
908
   end Next_Tag_Component;
909
 
910
   --------------------------
911
   -- Number_Discriminants --
912
   --------------------------
913
 
914
   function Number_Discriminants (Typ : Entity_Id) return Pos is
915
      N     : Int;
916
      Discr : Entity_Id;
917
 
918
   begin
919
      N := 0;
920
      Discr := First_Discriminant (Typ);
921
      while Present (Discr) loop
922
         N := N + 1;
923
         Discr := Next_Discriminant (Discr);
924
      end loop;
925
 
926
      return N;
927
   end Number_Discriminants;
928
 
929
   ---------------
930
   -- Tree_Read --
931
   ---------------
932
 
933
   procedure Tree_Read is
934
   begin
935
      Obsolescent_Warnings.Tree_Read;
936
   end Tree_Read;
937
 
938
   ----------------
939
   -- Tree_Write --
940
   ----------------
941
 
942
   procedure Tree_Write is
943
   begin
944
      Obsolescent_Warnings.Tree_Write;
945
   end Tree_Write;
946
 
947
   --------------------
948
   -- Ultimate_Alias --
949
   --------------------
950
 
951
   function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
952
      E : Entity_Id := Prim;
953
 
954
   begin
955
      while Present (Alias (E)) loop
956
         pragma Assert (Alias (E) /= E);
957
         E := Alias (E);
958
      end loop;
959
 
960
      return E;
961
   end Ultimate_Alias;
962
 
963
   --------------------------
964
   -- Unit_Declaration_Node --
965
   --------------------------
966
 
967
   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
968
      N : Node_Id := Parent (Unit_Id);
969
 
970
   begin
971
      --  Predefined operators do not have a full function declaration
972
 
973
      if Ekind (Unit_Id) = E_Operator then
974
         return N;
975
      end if;
976
 
977
      --  Isn't there some better way to express the following ???
978
 
979
      while Nkind (N) /= N_Abstract_Subprogram_Declaration
980
        and then Nkind (N) /= N_Formal_Package_Declaration
981
        and then Nkind (N) /= N_Function_Instantiation
982
        and then Nkind (N) /= N_Generic_Package_Declaration
983
        and then Nkind (N) /= N_Generic_Subprogram_Declaration
984
        and then Nkind (N) /= N_Package_Declaration
985
        and then Nkind (N) /= N_Package_Body
986
        and then Nkind (N) /= N_Package_Instantiation
987
        and then Nkind (N) /= N_Package_Renaming_Declaration
988
        and then Nkind (N) /= N_Procedure_Instantiation
989
        and then Nkind (N) /= N_Protected_Body
990
        and then Nkind (N) /= N_Subprogram_Declaration
991
        and then Nkind (N) /= N_Subprogram_Body
992
        and then Nkind (N) /= N_Subprogram_Body_Stub
993
        and then Nkind (N) /= N_Subprogram_Renaming_Declaration
994
        and then Nkind (N) /= N_Task_Body
995
        and then Nkind (N) /= N_Task_Type_Declaration
996
        and then Nkind (N) not in N_Formal_Subprogram_Declaration
997
        and then Nkind (N) not in N_Generic_Renaming_Declaration
998
      loop
999
         N := Parent (N);
1000
 
1001
         --  We don't use Assert here, because that causes an infinite loop
1002
         --  when assertions are turned off. Better to crash.
1003
 
1004
         if No (N) then
1005
            raise Program_Error;
1006
         end if;
1007
      end loop;
1008
 
1009
      return N;
1010
   end Unit_Declaration_Node;
1011
 
1012
end Sem_Aux;

powered by: WebSVN 2.1.0

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