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

Subversion Repositories openrisc

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

powered by: WebSVN 2.1.0

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