OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [exp_ch2.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              E X P _ C H 2                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Debug;    use Debug;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Errout;   use Errout;
31
with Exp_Smem; use Exp_Smem;
32
with Exp_Tss;  use Exp_Tss;
33
with Exp_Util; use Exp_Util;
34
with Exp_VFpt; use Exp_VFpt;
35
with Namet;    use Namet;
36
with Nmake;    use Nmake;
37
with Opt;      use Opt;
38
with Output;   use Output;
39
with Sem;      use Sem;
40
with Sem_Eval; use Sem_Eval;
41
with Sem_Res;  use Sem_Res;
42
with Sem_Util; use Sem_Util;
43
with Sem_Warn; use Sem_Warn;
44
with Sinfo;    use Sinfo;
45
with Sinput;   use Sinput;
46
with Snames;   use Snames;
47
with Tbuild;   use Tbuild;
48
with Uintp;    use Uintp;
49
 
50
package body Exp_Ch2 is
51
 
52
   -----------------------
53
   -- Local Subprograms --
54
   -----------------------
55
 
56
   procedure Expand_Current_Value (N : Node_Id);
57
   --  N is a node for a variable whose Current_Value field is set. If N is
58
   --  node is for a discrete type, replaces node with a copy of the referenced
59
   --  value. This provides a limited form of value propagation for variables
60
   --  which are initialized or assigned not been further modified at the time
61
   --  of reference. The call has no effect if the Current_Value refers to a
62
   --  conditional with condition other than equality.
63
 
64
   procedure Expand_Discriminant (N : Node_Id);
65
   --  An occurrence of a discriminant within a discriminated type is replaced
66
   --  with the corresponding discriminal, that is to say the formal parameter
67
   --  of the initialization procedure for the type that is associated with
68
   --  that particular discriminant. This replacement is not performed for
69
   --  discriminants of records that appear in constraints of component of the
70
   --  record, because Gigi uses the discriminant name to retrieve its value.
71
   --  In the other hand, it has to be performed for default expressions of
72
   --  components because they are used in the record init procedure. See Einfo
73
   --  for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
74
   --  discriminants of tasks and protected types, the transformation is more
75
   --  complex when it occurs within a default expression for an entry or
76
   --  protected operation. The corresponding default_expression_function has
77
   --  an additional parameter which is the target of an entry call, and the
78
   --  discriminant of the task must be replaced with a reference to the
79
   --  discriminant of that formal parameter.
80
 
81
   procedure Expand_Entity_Reference (N : Node_Id);
82
   --  Common processing for expansion of identifiers and expanded names
83
   --  Dispatches to specific expansion procedures.
84
 
85
   procedure Expand_Entry_Index_Parameter (N : Node_Id);
86
   --  A reference to the identifier in the entry index specification of an
87
   --  entry body is modified to a reference to a constant definition equal to
88
   --  the index of the entry family member being called. This constant is
89
   --  calculated as part of the elaboration of the expanded code for the body,
90
   --  and is calculated from the object-wide entry index returned by Next_
91
   --  Entry_Call.
92
 
93
   procedure Expand_Entry_Parameter (N : Node_Id);
94
   --  A reference to an entry parameter is modified to be a reference to the
95
   --  corresponding component of the entry parameter record that is passed by
96
   --  the runtime to the accept body procedure.
97
 
98
   procedure Expand_Formal (N : Node_Id);
99
   --  A reference to a formal parameter of a protected subprogram is expanded
100
   --  into the corresponding formal of the unprotected procedure used to
101
   --  represent the operation within the protected object. In other cases
102
   --  Expand_Formal is a no-op.
103
 
104
   procedure Expand_Protected_Component (N : Node_Id);
105
   --  A reference to a private component of a protected type is expanded into
106
   --  a reference to the corresponding prival in the current protected entry
107
   --  or subprogram.
108
 
109
   procedure Expand_Renaming (N : Node_Id);
110
   --  For renamings, just replace the identifier by the corresponding
111
   --  named expression. Note that this has been evaluated (see routine
112
   --  Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
113
   --  the correct renaming semantics.
114
 
115
   --------------------------
116
   -- Expand_Current_Value --
117
   --------------------------
118
 
119
   procedure Expand_Current_Value (N : Node_Id) is
120
      Loc : constant Source_Ptr := Sloc (N);
121
      E   : constant Entity_Id  := Entity (N);
122
      CV  : constant Node_Id    := Current_Value (E);
123
      T   : constant Entity_Id  := Etype (N);
124
      Val : Node_Id;
125
      Op  : Node_Kind;
126
 
127
   --  Start of processing for Expand_Current_Value
128
 
129
   begin
130
      if True
131
 
132
         --  No replacement if value raises constraint error
133
 
134
         and then Nkind (CV) /= N_Raise_Constraint_Error
135
 
136
         --  Do this only for discrete types
137
 
138
         and then Is_Discrete_Type (T)
139
 
140
         --  Do not replace biased types, since it is problematic to
141
         --  consistently generate a sensible constant value in this case.
142
 
143
         and then not Has_Biased_Representation (T)
144
 
145
         --  Do not replace lvalues
146
 
147
         and then not May_Be_Lvalue (N)
148
 
149
         --  Check that entity is suitable for replacement
150
 
151
         and then OK_To_Do_Constant_Replacement (E)
152
 
153
         --  Do not replace occurrences in pragmas (where names typically
154
         --  appear not as values, but as simply names. If there are cases
155
         --  where values are required, it is only a very minor efficiency
156
         --  issue that they do not get replaced when they could be).
157
 
158
         and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
159
 
160
         --  Do not replace the prefixes of attribute references, since this
161
         --  causes trouble with cases like 4'Size. Also for Name_Asm_Input and
162
         --  Name_Asm_Output, don't do replacement anywhere, since we can have
163
         --  lvalue references in the arguments.
164
 
165
         and then not (Nkind (Parent (N)) = N_Attribute_Reference
166
                         and then
167
                           (Attribute_Name (Parent (N)) = Name_Asm_Input
168
                              or else
169
                            Attribute_Name (Parent (N)) = Name_Asm_Output
170
                              or else
171
                            Prefix (Parent (N)) = N))
172
 
173
      then
174
         --  Case of Current_Value is a compile time known value
175
 
176
         if Nkind (CV) in N_Subexpr then
177
            Val := CV;
178
 
179
         --  Case of Current_Value is a conditional expression reference
180
 
181
         else
182
            Get_Current_Value_Condition (N, Op, Val);
183
 
184
            if Op /= N_Op_Eq then
185
               return;
186
            end if;
187
         end if;
188
 
189
         --  If constant value is an occurrence of an enumeration literal,
190
         --  then we just make another occurrence of the same literal.
191
 
192
         if Is_Entity_Name (Val)
193
           and then Ekind (Entity (Val)) = E_Enumeration_Literal
194
         then
195
            Rewrite (N,
196
              Unchecked_Convert_To (T,
197
                New_Occurrence_Of (Entity (Val), Loc)));
198
 
199
         --  If constant is of an integer type, just make an appropriately
200
         --  integer literal, which will get the proper type.
201
 
202
         elsif Is_Integer_Type (T) then
203
            Rewrite (N,
204
              Make_Integer_Literal (Loc,
205
                Intval => Expr_Rep_Value (Val)));
206
 
207
         --  Otherwise do unchecked conversion of value to right type
208
 
209
         else
210
            Rewrite (N,
211
              Unchecked_Convert_To (T,
212
                 Make_Integer_Literal (Loc,
213
                   Intval => Expr_Rep_Value (Val))));
214
         end if;
215
 
216
         Analyze_And_Resolve (N, T);
217
         Set_Is_Static_Expression (N, False);
218
      end if;
219
   end Expand_Current_Value;
220
 
221
   -------------------------
222
   -- Expand_Discriminant --
223
   -------------------------
224
 
225
   procedure Expand_Discriminant (N : Node_Id) is
226
      Scop     : constant Entity_Id := Scope (Entity (N));
227
      P        : Node_Id := N;
228
      Parent_P : Node_Id := Parent (P);
229
      In_Entry : Boolean := False;
230
 
231
   begin
232
      --  The Incomplete_Or_Private_Kind happens while resolving the
233
      --  discriminant constraint involved in a derived full type,
234
      --  such as:
235
 
236
      --    type D is private;
237
      --    type D(C : ...) is new T(C);
238
 
239
      if Ekind (Scop) = E_Record_Type
240
        or Ekind (Scop) in Incomplete_Or_Private_Kind
241
      then
242
         --  Find the origin by walking up the tree till the component
243
         --  declaration
244
 
245
         while Present (Parent_P)
246
           and then Nkind (Parent_P) /= N_Component_Declaration
247
         loop
248
            P := Parent_P;
249
            Parent_P := Parent (P);
250
         end loop;
251
 
252
         --  If the discriminant reference was part of the default expression
253
         --  it has to be "discriminalized"
254
 
255
         if Present (Parent_P) and then P = Expression (Parent_P) then
256
            Set_Entity (N, Discriminal (Entity (N)));
257
         end if;
258
 
259
      elsif Is_Concurrent_Type (Scop) then
260
         while Present (Parent_P)
261
           and then Nkind (Parent_P) /= N_Subprogram_Body
262
         loop
263
            P := Parent_P;
264
 
265
            if Nkind (P) = N_Entry_Declaration then
266
               In_Entry := True;
267
            end if;
268
 
269
            Parent_P := Parent (Parent_P);
270
         end loop;
271
 
272
         --  If the discriminant occurs within the default expression for a
273
         --  formal of an entry or protected operation, replace it with a
274
         --  reference to the discriminant of the formal of the enclosing
275
         --  operation.
276
 
277
         if Present (Parent_P)
278
           and then Present (Corresponding_Spec (Parent_P))
279
         then
280
            declare
281
               Loc    : constant Source_Ptr := Sloc (N);
282
               D_Fun  : constant Entity_Id := Corresponding_Spec  (Parent_P);
283
               Formal : constant Entity_Id := First_Formal (D_Fun);
284
               New_N  : Node_Id;
285
               Disc   : Entity_Id;
286
 
287
            begin
288
               --  Verify that we are within the body of an entry or protected
289
               --  operation. Its first formal parameter is the synchronized
290
               --  type itself.
291
 
292
               if Present (Formal)
293
                 and then Etype (Formal) = Scope (Entity (N))
294
               then
295
                  Disc := CR_Discriminant (Entity (N));
296
 
297
                  New_N :=
298
                    Make_Selected_Component (Loc,
299
                      Prefix => New_Occurrence_Of (Formal, Loc),
300
                      Selector_Name => New_Occurrence_Of (Disc, Loc));
301
 
302
                  Set_Etype (New_N, Etype (N));
303
                  Rewrite (N, New_N);
304
 
305
               else
306
                  Set_Entity (N, Discriminal (Entity (N)));
307
               end if;
308
            end;
309
 
310
         elsif Nkind (Parent (N)) = N_Range
311
           and then In_Entry
312
         then
313
            Set_Entity (N, CR_Discriminant (Entity (N)));
314
 
315
            --  Finally, if the entity is the discriminant of the original
316
            --  type declaration, and we are within the initialization
317
            --  procedure for a task, the designated entity is the
318
            --  discriminal of the task body. This can happen when the
319
            --  argument of pragma Task_Name mentions a discriminant,
320
            --  because the pragma is analyzed in the task declaration
321
            --  but is expanded in the call to Create_Task in the init_proc.
322
 
323
         elsif Within_Init_Proc then
324
            Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));
325
         else
326
            Set_Entity (N, Discriminal (Entity (N)));
327
         end if;
328
 
329
      else
330
         Set_Entity (N, Discriminal (Entity (N)));
331
      end if;
332
   end Expand_Discriminant;
333
 
334
   -----------------------------
335
   -- Expand_Entity_Reference --
336
   -----------------------------
337
 
338
   procedure Expand_Entity_Reference (N : Node_Id) is
339
      E : constant Entity_Id := Entity (N);
340
 
341
   begin
342
      --  Defend against errors
343
 
344
      if No (E) and then Total_Errors_Detected /= 0 then
345
         return;
346
      end if;
347
 
348
      if Ekind (E) = E_Discriminant then
349
         Expand_Discriminant (N);
350
 
351
      elsif Is_Entry_Formal (E) then
352
         Expand_Entry_Parameter (N);
353
 
354
      elsif Is_Protected_Component (E) then
355
         if No_Run_Time_Mode then
356
            return;
357
         end if;
358
 
359
         Expand_Protected_Component (N);
360
 
361
      elsif Ekind (E) = E_Entry_Index_Parameter then
362
         Expand_Entry_Index_Parameter (N);
363
 
364
      elsif Is_Formal (E) then
365
         Expand_Formal (N);
366
 
367
      elsif Is_Renaming_Of_Object (E) then
368
         Expand_Renaming (N);
369
 
370
      elsif Ekind (E) = E_Variable
371
        and then Is_Shared_Passive (E)
372
      then
373
         Expand_Shared_Passive_Variable (N);
374
      end if;
375
 
376
      --  Test code for implementing the pragma Reviewable requirement of
377
      --  classifying reads of scalars as referencing potentially uninitialized
378
      --  objects or not.
379
 
380
      if Debug_Flag_XX
381
        and then Is_Scalar_Type (Etype (N))
382
        and then (Is_Assignable (E) or else Is_Constant_Object (E))
383
        and then Comes_From_Source (N)
384
        and then not Is_LHS (N)
385
        and then not Is_Actual_Out_Parameter (N)
386
        and then (Nkind (Parent (N)) /= N_Attribute_Reference
387
                   or else Attribute_Name (Parent (N)) /= Name_Valid)
388
      then
389
         Write_Location (Sloc (N));
390
         Write_Str (": Read from scalar """);
391
         Write_Name (Chars (N));
392
         Write_Str ("""");
393
 
394
         if Is_Known_Valid (E) then
395
            Write_Str (", Is_Known_Valid");
396
         end if;
397
 
398
         Write_Eol;
399
      end if;
400
 
401
      --  Interpret possible Current_Value for variable case
402
 
403
      if Is_Assignable (E)
404
        and then Present (Current_Value (E))
405
      then
406
         Expand_Current_Value (N);
407
 
408
         --  We do want to warn for the case of a boolean variable (not a
409
         --  boolean constant) whose value is known at compile time.
410
 
411
         if Is_Boolean_Type (Etype (N)) then
412
            Warn_On_Known_Condition (N);
413
         end if;
414
 
415
      --  Don't mess with Current_Value for compile time known values. Not
416
      --  only is it unnecessary, but we could disturb an indication of a
417
      --  static value, which could cause semantic trouble.
418
 
419
      elsif Compile_Time_Known_Value (N) then
420
         null;
421
 
422
      --  Interpret possible Current_Value for constant case
423
 
424
      elsif Is_Constant_Object (E)
425
        and then Present (Current_Value (E))
426
      then
427
         Expand_Current_Value (N);
428
      end if;
429
   end Expand_Entity_Reference;
430
 
431
   ----------------------------------
432
   -- Expand_Entry_Index_Parameter --
433
   ----------------------------------
434
 
435
   procedure Expand_Entry_Index_Parameter (N : Node_Id) is
436
      Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
437
   begin
438
      Set_Entity (N, Index_Con);
439
      Set_Etype  (N, Etype (Index_Con));
440
   end Expand_Entry_Index_Parameter;
441
 
442
   ----------------------------
443
   -- Expand_Entry_Parameter --
444
   ----------------------------
445
 
446
   procedure Expand_Entry_Parameter (N : Node_Id) is
447
      Loc        : constant Source_Ptr := Sloc (N);
448
      Ent_Formal : constant Entity_Id  := Entity (N);
449
      Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);
450
      Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);
451
      Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);
452
      Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));
453
      P_Comp_Ref : Entity_Id;
454
 
455
      function In_Assignment_Context (N : Node_Id) return Boolean;
456
      --  Check whether this is a context in which the entry formal may be
457
      --  assigned to.
458
 
459
      ---------------------------
460
      -- In_Assignment_Context --
461
      ---------------------------
462
 
463
      function In_Assignment_Context (N : Node_Id) return Boolean is
464
      begin
465
         --  Case of use in a call
466
 
467
         --  ??? passing a formal as actual for a mode IN formal is
468
         --  considered as an assignment?
469
 
470
         if Nkind_In (Parent (N), N_Procedure_Call_Statement,
471
                                  N_Entry_Call_Statement)
472
           or else (Nkind (Parent (N)) = N_Assignment_Statement
473
                      and then N = Name (Parent (N)))
474
         then
475
            return True;
476
 
477
         --  Case of a parameter association: climb up to enclosing call
478
 
479
         elsif Nkind (Parent (N)) = N_Parameter_Association then
480
            return In_Assignment_Context (Parent (N));
481
 
482
         --  Case of a selected component, indexed component or slice prefix:
483
         --  climb up the tree, unless the prefix is of an access type (in
484
         --  which case there is an implicit dereference, and the formal itself
485
         --  is not being assigned to).
486
 
487
         elsif Nkind_In (Parent (N), N_Selected_Component,
488
                                     N_Indexed_Component,
489
                                     N_Slice)
490
           and then N = Prefix (Parent (N))
491
           and then not Is_Access_Type (Etype (N))
492
           and then In_Assignment_Context (Parent (N))
493
         then
494
            return True;
495
 
496
         else
497
            return False;
498
         end if;
499
      end In_Assignment_Context;
500
 
501
   --  Start of processing for Expand_Entry_Parameter
502
 
503
   begin
504
      if Is_Task_Type (Scope (Ent_Spec))
505
        and then Comes_From_Source (Ent_Formal)
506
      then
507
         --  Before replacing the formal with the local renaming that is used
508
         --  in the accept block, note if this is an assignment context, and
509
         --  note the modification to avoid spurious warnings, because the
510
         --  original entity is not used further. If formal is unconstrained,
511
         --  we also generate an extra parameter to hold the Constrained
512
         --  attribute of the actual. No renaming is generated for this flag.
513
 
514
         --  Calling Note_Possible_Modification in the expander is dubious,
515
         --  because this generates a cross-reference entry, and should be
516
         --  done during semantic processing so it is called in -gnatc mode???
517
 
518
         if Ekind (Entity (N)) /= E_In_Parameter
519
           and then In_Assignment_Context (N)
520
         then
521
            Note_Possible_Modification (N, Sure => True);
522
         end if;
523
 
524
         Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
525
         return;
526
      end if;
527
 
528
      --  What we need is a reference to the corresponding component of the
529
      --  parameter record object. The Accept_Address field of the entry entity
530
      --  references the address variable that contains the address of the
531
      --  accept parameters record. We first have to do an unchecked conversion
532
      --  to turn this into a pointer to the parameter record and then we
533
      --  select the required parameter field.
534
 
535
      P_Comp_Ref :=
536
        Make_Selected_Component (Loc,
537
          Prefix =>
538
            Make_Explicit_Dereference (Loc,
539
              Unchecked_Convert_To (Parm_Type,
540
                New_Reference_To (Addr_Ent, Loc))),
541
          Selector_Name =>
542
            New_Reference_To (Entry_Component (Ent_Formal), Loc));
543
 
544
      --  For all types of parameters, the constructed parameter record object
545
      --  contains a pointer to the parameter. Thus we must dereference them to
546
      --  access them (this will often be redundant, since the dereference is
547
      --  implicit, but no harm is done by making it explicit).
548
 
549
      Rewrite (N,
550
        Make_Explicit_Dereference (Loc, P_Comp_Ref));
551
 
552
      Analyze (N);
553
   end Expand_Entry_Parameter;
554
 
555
   -------------------
556
   -- Expand_Formal --
557
   -------------------
558
 
559
   procedure Expand_Formal (N : Node_Id) is
560
      E    : constant Entity_Id  := Entity (N);
561
      Scop : constant Entity_Id  := Scope (E);
562
 
563
   begin
564
      --  Check whether the subprogram of which this is a formal is
565
      --  a protected operation. The initialization procedure for
566
      --  the corresponding record type is not itself a protected operation.
567
 
568
      if Is_Protected_Type (Scope (Scop))
569
        and then not Is_Init_Proc (Scop)
570
        and then Present (Protected_Formal (E))
571
      then
572
         Set_Entity (N, Protected_Formal (E));
573
      end if;
574
   end Expand_Formal;
575
 
576
   ----------------------------
577
   -- Expand_N_Expanded_Name --
578
   ----------------------------
579
 
580
   procedure Expand_N_Expanded_Name (N : Node_Id) is
581
   begin
582
      Expand_Entity_Reference (N);
583
   end Expand_N_Expanded_Name;
584
 
585
   -------------------------
586
   -- Expand_N_Identifier --
587
   -------------------------
588
 
589
   procedure Expand_N_Identifier (N : Node_Id) is
590
   begin
591
      Expand_Entity_Reference (N);
592
   end Expand_N_Identifier;
593
 
594
   ---------------------------
595
   -- Expand_N_Real_Literal --
596
   ---------------------------
597
 
598
   procedure Expand_N_Real_Literal (N : Node_Id) is
599
   begin
600
      if Vax_Float (Etype (N)) then
601
         Expand_Vax_Real_Literal (N);
602
      end if;
603
   end Expand_N_Real_Literal;
604
 
605
   --------------------------------
606
   -- Expand_Protected_Component --
607
   --------------------------------
608
 
609
   procedure Expand_Protected_Component (N : Node_Id) is
610
 
611
      function Inside_Eliminated_Body return Boolean;
612
      --  Determine whether the current entity is inside a subprogram or an
613
      --  entry which has been marked as eliminated.
614
 
615
      ----------------------------
616
      -- Inside_Eliminated_Body --
617
      ----------------------------
618
 
619
      function Inside_Eliminated_Body return Boolean is
620
         S : Entity_Id := Current_Scope;
621
 
622
      begin
623
         while Present (S) loop
624
            if (Ekind (S) = E_Entry
625
                  or else Ekind (S) = E_Entry_Family
626
                  or else Ekind (S) = E_Function
627
                  or else Ekind (S) = E_Procedure)
628
              and then Is_Eliminated (S)
629
            then
630
               return True;
631
            end if;
632
 
633
            S := Scope (S);
634
         end loop;
635
 
636
         return False;
637
      end Inside_Eliminated_Body;
638
 
639
   --  Start of processing for Expand_Protected_Component
640
 
641
   begin
642
      --  Eliminated bodies are not expanded and thus do not need privals
643
 
644
      if not Inside_Eliminated_Body then
645
         declare
646
            Priv : constant Entity_Id := Prival (Entity (N));
647
         begin
648
            Set_Entity (N, Priv);
649
            Set_Etype  (N, Etype (Priv));
650
         end;
651
      end if;
652
   end Expand_Protected_Component;
653
 
654
   ---------------------
655
   -- Expand_Renaming --
656
   ---------------------
657
 
658
   procedure Expand_Renaming (N : Node_Id) is
659
      E : constant Entity_Id := Entity (N);
660
      T : constant Entity_Id := Etype (N);
661
 
662
   begin
663
      Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
664
 
665
      --  We mark the copy as unanalyzed, so that it is sure to be reanalyzed
666
      --  at the top level. This is needed in the packed case since we
667
      --  specifically avoided expanding packed array references when the
668
      --  renaming declaration was analyzed.
669
 
670
      Reset_Analyzed_Flags (N);
671
      Analyze_And_Resolve (N, T);
672
   end Expand_Renaming;
673
 
674
   ------------------
675
   -- Param_Entity --
676
   ------------------
677
 
678
   --  This would be trivial, simply a test for an identifier that was a
679
   --  reference to a formal, if it were not for the fact that a previous call
680
   --  to Expand_Entry_Parameter will have modified the reference to the
681
   --  identifier. A formal of a protected entity is rewritten as
682
 
683
   --    typ!(recobj).rec.all'Constrained
684
 
685
   --  where rec is a selector whose Entry_Formal link points to the formal
686
   --  For a formal of a task entity, the formal is rewritten as a local
687
   --  renaming.
688
 
689
   --  In addition, a formal that is marked volatile because it is aliased
690
   --  through an address clause is rewritten as dereference as well.
691
 
692
   function Param_Entity (N : Node_Id) return Entity_Id is
693
      Renamed_Obj : Node_Id;
694
 
695
   begin
696
      --  Simple reference case
697
 
698
      if Nkind_In (N, N_Identifier, N_Expanded_Name) then
699
         if Is_Formal (Entity (N)) then
700
            return Entity (N);
701
 
702
         --  Handle renamings of formal parameters and formals of tasks that
703
         --  are rewritten as renamings.
704
 
705
         elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
706
            Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
707
 
708
            if Is_Entity_Name (Renamed_Obj)
709
              and then Is_Formal (Entity (Renamed_Obj))
710
            then
711
               return Entity (Renamed_Obj);
712
 
713
            elsif
714
              Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
715
            then
716
               return Entity (N);
717
            end if;
718
         end if;
719
 
720
      else
721
         if Nkind (N) = N_Explicit_Dereference then
722
            declare
723
               P : constant Node_Id := Prefix (N);
724
               S : Node_Id;
725
 
726
            begin
727
               if Nkind (P) = N_Selected_Component then
728
                  S := Selector_Name (P);
729
 
730
                  if Present (Entry_Formal (Entity (S))) then
731
                     return Entry_Formal (Entity (S));
732
                  end if;
733
 
734
               elsif Nkind (Original_Node (N)) = N_Identifier then
735
                  return Param_Entity (Original_Node (N));
736
               end if;
737
            end;
738
         end if;
739
      end if;
740
 
741
      return (Empty);
742
   end Param_Entity;
743
 
744
end Exp_Ch2;

powered by: WebSVN 2.1.0

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