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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [exp_ch13.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 1 3                              --
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 Einfo;    use Einfo;
29
with Exp_Ch3;  use Exp_Ch3;
30
with Exp_Ch6;  use Exp_Ch6;
31
with Exp_Imgv; use Exp_Imgv;
32
with Exp_Tss;  use Exp_Tss;
33
with Exp_Util; use Exp_Util;
34
with Namet;    use Namet;
35
with Nlists;   use Nlists;
36
with Nmake;    use Nmake;
37
with Opt;      use Opt;
38
with Restrict; use Restrict;
39
with Rident;   use Rident;
40
with Rtsfind;  use Rtsfind;
41
with Sem;      use Sem;
42
with Sem_Aux;  use Sem_Aux;
43
with Sem_Ch7;  use Sem_Ch7;
44
with Sem_Ch8;  use Sem_Ch8;
45
with Sem_Eval; use Sem_Eval;
46
with Sem_Util; use Sem_Util;
47
with Sinfo;    use Sinfo;
48
with Snames;   use Snames;
49
with Targparm; use Targparm;
50
with Tbuild;   use Tbuild;
51
with Uintp;    use Uintp;
52
with Validsw;  use Validsw;
53
 
54
package body Exp_Ch13 is
55
 
56
   ------------------------------------------
57
   -- Expand_N_Attribute_Definition_Clause --
58
   ------------------------------------------
59
 
60
   --  Expansion action depends on attribute involved
61
 
62
   procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
63
      Loc : constant Source_Ptr := Sloc (N);
64
      Exp : constant Node_Id    := Expression (N);
65
      Ent : Entity_Id;
66
      V   : Node_Id;
67
 
68
   begin
69
      Ent := Entity (Name (N));
70
 
71
      if Is_Type (Ent) then
72
         Ent := Underlying_Type (Ent);
73
      end if;
74
 
75
      case Get_Attribute_Id (Chars (N)) is
76
 
77
         -------------
78
         -- Address --
79
         -------------
80
 
81
         when Attribute_Address =>
82
 
83
            --  If there is an initialization which did not come from the
84
            --  source program, then it is an artifact of our expansion, and we
85
            --  suppress it. The case we are most concerned about here is the
86
            --  initialization of a packed array to all false, which seems
87
            --  inappropriate for variable to which an address clause is
88
            --  applied. The expression may itself have been rewritten if the
89
            --  type is packed array, so we need to examine whether the
90
            --  original node is in the source. An exception though is the case
91
            --  of an access variable which is default initialized to null, and
92
            --  such initialization is retained.
93
 
94
            --  Furthermore, if the initialization is the equivalent aggregate
95
            --  of the type initialization procedure, it replaces an implicit
96
            --  call to the init proc, and must be respected. Note that for
97
            --  packed types we do not build equivalent aggregates.
98
 
99
            --  Also, if Init_Or_Norm_Scalars applies, then we need to retain
100
            --  any default initialization for objects of scalar types and
101
            --  types with scalar components. Normally a composite type will
102
            --  have an init_proc in the presence of Init_Or_Norm_Scalars,
103
            --  so when that flag is set we have just have to do a test for
104
            --  scalar and string types (the predefined string types such as
105
            --  String and Wide_String don't have an init_proc).
106
 
107
            declare
108
               Decl : constant Node_Id := Declaration_Node (Ent);
109
               Typ  : constant Entity_Id := Etype (Ent);
110
 
111
            begin
112
               if Nkind (Decl) = N_Object_Declaration
113
                  and then Present (Expression (Decl))
114
                  and then Nkind (Expression (Decl)) /= N_Null
115
                  and then
116
                   not Comes_From_Source (Original_Node (Expression (Decl)))
117
               then
118
                  if Present (Base_Init_Proc (Typ))
119
                    and then
120
                      Present (Static_Initialization (Base_Init_Proc (Typ)))
121
                  then
122
                     null;
123
 
124
                  elsif Init_Or_Norm_Scalars
125
                    and then
126
                      (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
127
                  then
128
                     null;
129
 
130
                  else
131
                     Set_Expression (Decl, Empty);
132
                  end if;
133
 
134
               --  An object declaration to which an address clause applies
135
               --  has a delayed freeze, but the address expression itself
136
               --  must be elaborated at the point it appears. If the object
137
               --  is controlled, additional checks apply elsewhere.
138
 
139
               elsif Nkind (Decl) = N_Object_Declaration
140
                 and then not Needs_Constant_Address (Decl, Typ)
141
               then
142
                  Remove_Side_Effects (Exp);
143
               end if;
144
            end;
145
 
146
         ---------------
147
         -- Alignment --
148
         ---------------
149
 
150
         when Attribute_Alignment =>
151
 
152
            --  As required by Gigi, we guarantee that the operand is an
153
            --  integer literal (this simplifies things in Gigi).
154
 
155
            if Nkind (Exp) /= N_Integer_Literal then
156
               Rewrite
157
                 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
158
            end if;
159
 
160
         ------------------
161
         -- Storage_Size --
162
         ------------------
163
 
164
         when Attribute_Storage_Size =>
165
 
166
            --  If the type is a task type, then assign the value of the
167
            --  storage size to the Size variable associated with the task.
168
            --    task_typeZ := expression
169
 
170
            if Ekind (Ent) = E_Task_Type then
171
               Insert_Action (N,
172
                 Make_Assignment_Statement (Loc,
173
                   Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
174
                   Expression =>
175
                     Convert_To (RTE (RE_Size_Type), Expression (N))));
176
 
177
            --  For Storage_Size for an access type, create a variable to hold
178
            --  the value of the specified size with name typeV and expand an
179
            --  assignment statement to initialize this value.
180
 
181
            elsif Is_Access_Type (Ent) then
182
 
183
               --  We don't need the variable for a storage size of zero
184
 
185
               if not No_Pool_Assigned (Ent) then
186
                  V :=
187
                    Make_Defining_Identifier (Loc,
188
                      Chars => New_External_Name (Chars (Ent), 'V'));
189
 
190
                  --  Insert the declaration of the object
191
 
192
                  Insert_Action (N,
193
                    Make_Object_Declaration (Loc,
194
                      Defining_Identifier => V,
195
                      Object_Definition  =>
196
                        New_Reference_To (RTE (RE_Storage_Offset), Loc),
197
                      Expression =>
198
                        Convert_To (RTE (RE_Storage_Offset), Expression (N))));
199
 
200
                  Set_Storage_Size_Variable (Ent, Entity_Id (V));
201
               end if;
202
            end if;
203
 
204
         --  Other attributes require no expansion
205
 
206
         when others =>
207
            null;
208
 
209
      end case;
210
   end Expand_N_Attribute_Definition_Clause;
211
 
212
   -----------------------------
213
   -- Expand_N_Free_Statement --
214
   -----------------------------
215
 
216
   procedure Expand_N_Free_Statement (N : Node_Id) is
217
      Expr : constant Node_Id := Expression (N);
218
      Typ  : Entity_Id;
219
 
220
   begin
221
      --  Certain run-time configurations and targets do not provide support
222
      --  for controlled types.
223
 
224
      if Restriction_Active (No_Finalization) then
225
         return;
226
 
227
      --  Do not create a specialized Deallocate since .NET/JVM compilers do
228
      --  not support pools and address arithmetic.
229
 
230
      elsif VM_Target /= No_VM then
231
         return;
232
      end if;
233
 
234
      --  Use the base type to perform the check for finalization master
235
 
236
      Typ := Etype (Expr);
237
 
238
      if Ekind (Typ) = E_Access_Subtype then
239
         Typ := Etype (Typ);
240
      end if;
241
 
242
      --  Handle private access types
243
 
244
      if Is_Private_Type (Typ)
245
        and then Present (Full_View (Typ))
246
      then
247
         Typ := Full_View (Typ);
248
      end if;
249
 
250
      --  Do not create a custom Deallocate when freeing an object with
251
      --  suppressed finalization. In such cases the object is never attached
252
      --  to a master, so it does not need to be detached. Use a regular free
253
      --  statement instead.
254
 
255
      if No (Finalization_Master (Typ)) then
256
         return;
257
      end if;
258
 
259
      --  Use a temporary to store the result of a complex expression. Perform
260
      --  the following transformation:
261
      --
262
      --     Free (Complex_Expression);
263
      --
264
      --     Temp : constant Type_Of_Expression := Complex_Expression;
265
      --     Free (Temp);
266
 
267
      if Nkind (Expr) /= N_Identifier then
268
         declare
269
            Expr_Typ : constant Entity_Id  := Etype (Expr);
270
            Loc      : constant Source_Ptr := Sloc (N);
271
            New_Expr : Node_Id;
272
            Temp_Id  : Entity_Id;
273
 
274
         begin
275
            Temp_Id := Make_Temporary (Loc, 'T');
276
            Insert_Action (N,
277
              Make_Object_Declaration (Loc,
278
                Defining_Identifier => Temp_Id,
279
                Object_Definition =>
280
                  New_Reference_To (Expr_Typ, Loc),
281
                Expression =>
282
                  Relocate_Node (Expr)));
283
 
284
            New_Expr := New_Reference_To (Temp_Id, Loc);
285
            Set_Etype (New_Expr, Expr_Typ);
286
 
287
            Set_Expression (N, New_Expr);
288
         end;
289
      end if;
290
 
291
      --  Create a custom Deallocate for a controlled object. This routine
292
      --  ensures that the hidden list header will be deallocated along with
293
      --  the actual object.
294
 
295
      Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
296
   end Expand_N_Free_Statement;
297
 
298
   ----------------------------
299
   -- Expand_N_Freeze_Entity --
300
   ----------------------------
301
 
302
   procedure Expand_N_Freeze_Entity (N : Node_Id) is
303
      E              : constant Entity_Id := Entity (N);
304
      E_Scope        : Entity_Id;
305
      In_Other_Scope : Boolean;
306
      In_Outer_Scope : Boolean;
307
      Decl           : Node_Id;
308
      Delete         : Boolean := False;
309
 
310
   begin
311
      --  If there are delayed aspect specifications, we insert them just
312
      --  before the freeze node. They are already analyzed so we don't need
313
      --  to reanalyze them (they were analyzed before the type was frozen),
314
      --  but we want them in the tree for the back end, and so that the
315
      --  listing from sprint is clearer on where these occur logically.
316
 
317
      if Has_Delayed_Aspects (E) then
318
         declare
319
            Aitem : Node_Id;
320
            Ritem : Node_Id;
321
 
322
         begin
323
            --  Look for aspect specs for this entity
324
 
325
            Ritem := First_Rep_Item (E);
326
            while Present (Ritem) loop
327
               if Nkind (Ritem) = N_Aspect_Specification
328
                 and then Entity (Ritem) = E
329
               then
330
                  Aitem := Aspect_Rep_Item (Ritem);
331
 
332
                  --  Skip this for aspects (e.g. Current_Value) for which
333
                  --  there is no corresponding pragma or attribute.
334
 
335
                  if Present (Aitem) then
336
                     pragma Assert (Is_Delayed_Aspect (Aitem));
337
                     Insert_Before (N, Aitem);
338
                  end if;
339
               end if;
340
 
341
               Next_Rep_Item (Ritem);
342
            end loop;
343
         end;
344
      end if;
345
 
346
      --  Processing for objects with address clauses
347
 
348
      if Is_Object (E) and then Present (Address_Clause (E)) then
349
         Apply_Address_Clause_Check (E, N);
350
         return;
351
 
352
      --  Only other items requiring any front end action are types and
353
      --  subprograms.
354
 
355
      elsif not Is_Type (E) and then not Is_Subprogram (E) then
356
         return;
357
      end if;
358
 
359
      --  Here E is a type or a subprogram
360
 
361
      E_Scope := Scope (E);
362
 
363
      --  This is an error protection against previous errors
364
 
365
      if No (E_Scope) then
366
         return;
367
      end if;
368
 
369
      --  Remember that we are processing a freezing entity and its freezing
370
      --  nodes. This flag (non-zero = set) is used to avoid the need of
371
      --  climbing through the tree while processing the freezing actions (ie.
372
      --  to avoid generating spurious warnings or to avoid killing constant
373
      --  indications while processing the code associated with freezing
374
      --  actions). We use a counter to deal with nesting.
375
 
376
      Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
377
 
378
      --  If we are freezing entities defined in protected types, they belong
379
      --  in the enclosing scope, given that the original type has been
380
      --  expanded away. The same is true for entities in task types, in
381
      --  particular the parameter records of entries (Entities in bodies are
382
      --  all frozen within the body). If we are in the task body, this is a
383
      --  proper scope. If we are within a subprogram body, the proper scope
384
      --  is the corresponding spec. This may happen for itypes generated in
385
      --  the bodies of protected operations.
386
 
387
      if Ekind (E_Scope) = E_Protected_Type
388
        or else (Ekind (E_Scope) = E_Task_Type
389
                  and then not Has_Completion (E_Scope))
390
      then
391
         E_Scope := Scope (E_Scope);
392
 
393
      elsif Ekind (E_Scope) = E_Subprogram_Body then
394
         E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
395
      end if;
396
 
397
      --  If the scope of the entity is in open scopes, it is the current one
398
      --  or an enclosing one, including a loop, a block, or a subprogram.
399
 
400
      if In_Open_Scopes (E_Scope) then
401
         In_Other_Scope := False;
402
         In_Outer_Scope := E_Scope /= Current_Scope;
403
 
404
      --  Otherwise it is a local package or a different compilation unit
405
 
406
      else
407
         In_Other_Scope := True;
408
         In_Outer_Scope := False;
409
      end if;
410
 
411
      --  If the entity being frozen is defined in a scope that is not
412
      --  currently on the scope stack, we must establish the proper
413
      --  visibility before freezing the entity and related subprograms.
414
 
415
      if In_Other_Scope then
416
         Push_Scope (E_Scope);
417
 
418
         --  Finalizers are little odd in terms of freezing. The spec of the
419
         --  procedure appears in the declarations while the body appears in
420
         --  the statement part of a single construct. Since the finalizer must
421
         --  be called by the At_End handler of the construct, the spec is
422
         --  manually frozen right after its declaration. The only side effect
423
         --  of this action appears in contexts where the construct is not in
424
         --  its final resting place. These contexts are:
425
 
426
         --    * Entry bodies - The declarations and statements are moved to
427
         --      the procedure equivalen of the entry.
428
         --    * Protected subprograms - The declarations and statements are
429
         --      moved to the non-protected version of the subprogram.
430
         --    * Task bodies - The declarations and statements are moved to the
431
         --      task body procedure.
432
 
433
         --  Visible declarations do not need to be installed in these three
434
         --  cases since it does not make semantic sense to do so. All entities
435
         --  referenced by a finalizer are visible and already resolved, plus
436
         --  the enclosing scope may not have visible declarations at all.
437
 
438
         if Ekind (E) = E_Procedure
439
           and then Is_Finalizer (E)
440
           and then
441
             (Is_Entry (E_Scope)
442
                or else (Is_Subprogram (E_Scope)
443
                           and then Is_Protected_Type (Scope (E_Scope)))
444
                or else Is_Task_Type (E_Scope))
445
         then
446
            null;
447
         else
448
            Install_Visible_Declarations (E_Scope);
449
         end if;
450
 
451
         if Is_Package_Or_Generic_Package (E_Scope) or else
452
            Is_Protected_Type (E_Scope)             or else
453
            Is_Task_Type (E_Scope)
454
         then
455
            Install_Private_Declarations (E_Scope);
456
         end if;
457
 
458
      --  If the entity is in an outer scope, then that scope needs to
459
      --  temporarily become the current scope so that operations created
460
      --  during type freezing will be declared in the right scope and
461
      --  can properly override any corresponding inherited operations.
462
 
463
      elsif In_Outer_Scope then
464
         Push_Scope (E_Scope);
465
      end if;
466
 
467
      --  If type, freeze the type
468
 
469
      if Is_Type (E) then
470
         Delete := Freeze_Type (N);
471
 
472
         --  And for enumeration type, build the enumeration tables
473
 
474
         if Is_Enumeration_Type (E) then
475
            Build_Enumeration_Image_Tables (E, N);
476
         end if;
477
 
478
      --  If subprogram, freeze the subprogram
479
 
480
      elsif Is_Subprogram (E) then
481
         Freeze_Subprogram (N);
482
 
483
         --  Ada 2005 (AI-251): Remove the freezing node associated with the
484
         --  entities internally used by the frontend to register primitives
485
         --  covering abstract interfaces. The call to Freeze_Subprogram has
486
         --  already expanded the code that fills the corresponding entry in
487
         --  its secondary dispatch table and therefore the code generator
488
         --  has nothing else to do with this freezing node.
489
 
490
         Delete := Present (Interface_Alias (E));
491
      end if;
492
 
493
      --  Analyze actions generated by freezing. The init_proc contains source
494
      --  expressions that may raise Constraint_Error, and the assignment
495
      --  procedure for complex types needs checks on individual component
496
      --  assignments, but all other freezing actions should be compiled with
497
      --  all checks off.
498
 
499
      if Present (Actions (N)) then
500
         Decl := First (Actions (N));
501
         while Present (Decl) loop
502
            if Nkind (Decl) = N_Subprogram_Body
503
              and then (Is_Init_Proc (Defining_Entity (Decl))
504
                          or else
505
                            Chars (Defining_Entity (Decl)) = Name_uAssign)
506
            then
507
               Analyze (Decl);
508
 
509
            --  A subprogram body created for a renaming_as_body completes
510
            --  a previous declaration, which may be in a different scope.
511
            --  Establish the proper scope before analysis.
512
 
513
            elsif Nkind (Decl) = N_Subprogram_Body
514
              and then Present (Corresponding_Spec (Decl))
515
              and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
516
            then
517
               Push_Scope (Scope (Corresponding_Spec (Decl)));
518
               Analyze (Decl, Suppress => All_Checks);
519
               Pop_Scope;
520
 
521
            --  We treat generated equality specially, if validity checks are
522
            --  enabled, in order to detect components default-initialized
523
            --  with invalid values.
524
 
525
            elsif Nkind (Decl) = N_Subprogram_Body
526
              and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
527
              and then Validity_Checks_On
528
              and then Initialize_Scalars
529
            then
530
               declare
531
                  Save_Force : constant Boolean := Force_Validity_Checks;
532
               begin
533
                  Force_Validity_Checks := True;
534
                  Analyze (Decl);
535
                  Force_Validity_Checks := Save_Force;
536
               end;
537
 
538
            else
539
               Analyze (Decl, Suppress => All_Checks);
540
            end if;
541
 
542
            Next (Decl);
543
         end loop;
544
      end if;
545
 
546
      --  If we are to delete this N_Freeze_Entity, do so by rewriting so that
547
      --  a loop on all nodes being inserted will work propertly.
548
 
549
      if Delete then
550
         Rewrite (N, Make_Null_Statement (Sloc (N)));
551
      end if;
552
 
553
      --  Pop scope if we installed one for the analysis
554
 
555
      if In_Other_Scope then
556
         if Ekind (Current_Scope) = E_Package then
557
            End_Package_Scope (E_Scope);
558
         else
559
            End_Scope;
560
         end if;
561
 
562
      elsif In_Outer_Scope then
563
         Pop_Scope;
564
      end if;
565
 
566
      --  Restore previous value of the nesting-level counter that records
567
      --  whether we are inside a (possibly nested) call to this procedure.
568
 
569
      Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
570
   end Expand_N_Freeze_Entity;
571
 
572
   -------------------------------------------
573
   -- Expand_N_Record_Representation_Clause --
574
   -------------------------------------------
575
 
576
   --  The only expansion required is for the case of a mod clause present,
577
   --  which is removed, and translated into an alignment representation
578
   --  clause inserted immediately after the record rep clause with any
579
   --  initial pragmas inserted at the start of the component clause list.
580
 
581
   procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
582
      Loc     : constant Source_Ptr := Sloc (N);
583
      Rectype : constant Entity_Id  := Entity (Identifier (N));
584
      Mod_Val : Uint;
585
      Citems  : List_Id;
586
      Repitem : Node_Id;
587
      AtM_Nod : Node_Id;
588
 
589
   begin
590
      if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
591
         Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
592
         Citems  := Pragmas_Before (Mod_Clause (N));
593
 
594
         if Present (Citems) then
595
            Append_List_To (Citems, Component_Clauses (N));
596
            Set_Component_Clauses (N, Citems);
597
         end if;
598
 
599
         AtM_Nod :=
600
           Make_Attribute_Definition_Clause (Loc,
601
             Name       => New_Reference_To (Base_Type (Rectype), Loc),
602
             Chars      => Name_Alignment,
603
             Expression => Make_Integer_Literal (Loc, Mod_Val));
604
 
605
         Set_From_At_Mod (AtM_Nod);
606
         Insert_After (N, AtM_Nod);
607
         Set_Mod_Clause (N, Empty);
608
      end if;
609
 
610
      --  If the record representation clause has no components, then
611
      --  completely remove it.  Note that we also have to remove
612
      --  ourself from the Rep Item list.
613
 
614
      if Is_Empty_List (Component_Clauses (N)) then
615
         if First_Rep_Item (Rectype) = N then
616
            Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
617
         else
618
            Repitem := First_Rep_Item (Rectype);
619
            while Present (Next_Rep_Item (Repitem)) loop
620
               if Next_Rep_Item (Repitem) = N then
621
                  Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
622
                  exit;
623
               end if;
624
 
625
               Next_Rep_Item (Repitem);
626
            end loop;
627
         end if;
628
 
629
         Rewrite (N,
630
           Make_Null_Statement (Loc));
631
      end if;
632
   end Expand_N_Record_Representation_Clause;
633
 
634
end Exp_Ch13;

powered by: WebSVN 2.1.0

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