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

Subversion Repositories openrisc

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

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

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             E X P _ I N T R                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Elists;   use Elists;
30
with Errout;   use Errout;
31
with Exp_Atag; use Exp_Atag;
32
with Exp_Ch4;  use Exp_Ch4;
33
with Exp_Ch7;  use Exp_Ch7;
34
with Exp_Ch11; use Exp_Ch11;
35
with Exp_Code; use Exp_Code;
36
with Exp_Fixd; use Exp_Fixd;
37
with Exp_Util; use Exp_Util;
38
with Freeze;   use Freeze;
39
with Namet;    use Namet;
40
with Nmake;    use Nmake;
41
with Nlists;   use Nlists;
42
with Opt;      use Opt;
43
with Restrict; use Restrict;
44
with Rident;   use Rident;
45
with Rtsfind;  use Rtsfind;
46
with Sem;      use Sem;
47
with Sem_Eval; use Sem_Eval;
48
with Sem_Res;  use Sem_Res;
49
with Sem_Type; use Sem_Type;
50
with Sem_Util; use Sem_Util;
51
with Sinfo;    use Sinfo;
52
with Sinput;   use Sinput;
53
with Snames;   use Snames;
54
with Stand;    use Stand;
55
with Stringt;  use Stringt;
56
with Targparm; use Targparm;
57
with Tbuild;   use Tbuild;
58
with Uintp;    use Uintp;
59
with Urealp;   use Urealp;
60
 
61
package body Exp_Intr is
62
 
63
   -----------------------
64
   -- Local Subprograms --
65
   -----------------------
66
 
67
   procedure Expand_Binary_Operator_Call (N : Node_Id);
68
   --  Expand a call to an intrinsic arithmetic operator when the operand
69
   --  types or sizes are not identical.
70
 
71
   procedure Expand_Is_Negative (N : Node_Id);
72
   --  Expand a call to the intrinsic Is_Negative function
73
 
74
   procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
75
   --  Expand a call to an instantiation of Generic_Dispatching_Constructor
76
   --  into a dispatching call to the actual subprogram associated with the
77
   --  Constructor formal subprogram, passing it the Parameters actual of
78
   --  the call to the instantiation and dispatching based on call's Tag
79
   --  parameter.
80
 
81
   procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
82
   --  Expand a call to Exception_Information/Message/Name. The first
83
   --  parameter, N, is the node for the function call, and Ent is the
84
   --  entity for the corresponding routine in the Ada.Exceptions package.
85
 
86
   procedure Expand_Import_Call (N : Node_Id);
87
   --  Expand a call to Import_Address/Longest_Integer/Value. The parameter
88
   --  N is the node for the function call.
89
 
90
   procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
91
   --  Expand an intrinsic shift operation, N and E are from the call to
92
   --  Expand_Intrinsic_Call (call node and subprogram spec entity) and
93
   --  K is the kind for the shift node
94
 
95
   procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
96
   --  Expand a call to an instantiation of Unchecked_Conversion into a node
97
   --  N_Unchecked_Type_Conversion.
98
 
99
   procedure Expand_Unc_Deallocation (N : Node_Id);
100
   --  Expand a call to an instantiation of Unchecked_Deallocation into a node
101
   --  N_Free_Statement and appropriate context.
102
 
103
   procedure Expand_To_Address (N : Node_Id);
104
   procedure Expand_To_Pointer (N : Node_Id);
105
   --  Expand a call to corresponding function, declared in an instance of
106
   --  System.Address_To_Access_Conversions.
107
 
108
   procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
109
   --  Rewrite the node by the appropriate string or positive constant.
110
   --  Nam can be one of the following:
111
   --    Name_File             - expand string that is the name of source file
112
   --    Name_Line             - expand integer line number
113
   --    Name_Source_Location  - expand string of form file:line
114
   --    Name_Enclosing_Entity - expand string  with name of enclosing entity
115
 
116
   ---------------------------------
117
   -- Expand_Binary_Operator_Call --
118
   ---------------------------------
119
 
120
   procedure Expand_Binary_Operator_Call (N : Node_Id) is
121
      T1  : constant Entity_Id := Underlying_Type (Etype (Left_Opnd  (N)));
122
      T2  : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));
123
      TR  : constant Entity_Id := Etype (N);
124
      T3  : Entity_Id;
125
      Res : Node_Id;
126
 
127
      Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));
128
      --  Maximum of operand sizes
129
 
130
   begin
131
      --  Nothing to do if the operands have the same modular type
132
 
133
      if Base_Type (T1) = Base_Type (T2)
134
        and then Is_Modular_Integer_Type (T1)
135
      then
136
         return;
137
      end if;
138
 
139
      --  Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
140
 
141
      if Siz > 32 then
142
         T3 := RTE (RE_Unsigned_64);
143
      else
144
         T3 := RTE (RE_Unsigned_32);
145
      end if;
146
 
147
      --  Copy operator node, and reset type and entity fields, for
148
      --  subsequent reanalysis.
149
 
150
      Res := New_Copy (N);
151
      Set_Etype (Res, T3);
152
 
153
      case Nkind (N) is
154
         when N_Op_And =>
155
            Set_Entity (Res, Standard_Op_And);
156
         when N_Op_Or =>
157
            Set_Entity (Res, Standard_Op_Or);
158
         when N_Op_Xor =>
159
            Set_Entity (Res, Standard_Op_Xor);
160
         when others =>
161
            raise Program_Error;
162
      end case;
163
 
164
      --  Convert operands to large enough intermediate type
165
 
166
      Set_Left_Opnd (Res,
167
        Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
168
      Set_Right_Opnd (Res,
169
        Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
170
 
171
      --  Analyze and resolve result formed by conversion to target type
172
 
173
      Rewrite (N, Unchecked_Convert_To (TR, Res));
174
      Analyze_And_Resolve (N, TR);
175
   end Expand_Binary_Operator_Call;
176
 
177
   -----------------------------------------
178
   -- Expand_Dispatching_Constructor_Call --
179
   -----------------------------------------
180
 
181
   --  Transform a call to an instantiation of Generic_Dispatching_Constructor
182
   --  of the form:
183
 
184
   --     GDC_Instance (The_Tag, Parameters'Access)
185
 
186
   --  to a class-wide conversion of a dispatching call to the actual
187
   --  associated with the formal subprogram Construct, designating The_Tag
188
   --  as the controlling tag of the call:
189
 
190
   --     T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
191
 
192
   --  which will eventually be expanded to the following:
193
 
194
   --     T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
195
 
196
   --  A class-wide membership test is also generated, preceding the call, to
197
   --  ensure that the controlling tag denotes a type in T'Class.
198
 
199
   procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is
200
      Loc        : constant Source_Ptr := Sloc (N);
201
      Tag_Arg    : constant Node_Id    := First_Actual (N);
202
      Param_Arg  : constant Node_Id    := Next_Actual (Tag_Arg);
203
      Subp_Decl  : constant Node_Id    := Parent (Parent (Entity (Name (N))));
204
      Inst_Pkg   : constant Node_Id    := Parent (Subp_Decl);
205
      Act_Rename : Node_Id;
206
      Act_Constr : Entity_Id;
207
      Iface_Tag  : Node_Id := Empty;
208
      Cnstr_Call : Node_Id;
209
      Result_Typ : Entity_Id;
210
 
211
   begin
212
      --  The subprogram is the third actual in the instantiation, and is
213
      --  retrieved from the corresponding renaming declaration. However,
214
      --  freeze nodes may appear before, so we retrieve the declaration
215
      --  with an explicit loop.
216
 
217
      Act_Rename := First (Visible_Declarations (Inst_Pkg));
218
      while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop
219
         Next (Act_Rename);
220
      end loop;
221
 
222
      Act_Constr := Entity (Name (Act_Rename));
223
      Result_Typ := Class_Wide_Type (Etype (Act_Constr));
224
 
225
      --  Ada 2005 (AI-251): If the result is an interface type, the function
226
      --  returns a class-wide interface type (otherwise the resulting object
227
      --  would be abstract!)
228
 
229
      if Is_Interface (Etype (Act_Constr)) then
230
         Set_Etype (Act_Constr, Result_Typ);
231
 
232
         --  If the result type is not parent of Tag_Arg then we need to
233
         --  locate the tag of the secondary dispatch table.
234
 
235
         if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
236
                             Use_Full_View => True)
237
           and then Tagged_Type_Expansion
238
         then
239
            --  Obtain the reference to the Ada.Tags service before generating
240
            --  the Object_Declaration node to ensure that if this service is
241
            --  not available in the runtime then we generate a clear error.
242
 
243
            declare
244
               Fname : constant Node_Id :=
245
                         New_Reference_To (RTE (RE_Secondary_Tag), Loc);
246
 
247
            begin
248
               pragma Assert (not Is_Interface (Etype (Tag_Arg)));
249
 
250
               Iface_Tag :=
251
                 Make_Object_Declaration (Loc,
252
                   Defining_Identifier => Make_Temporary (Loc, 'V'),
253
                   Object_Definition   =>
254
                     New_Reference_To (RTE (RE_Tag), Loc),
255
                   Expression          =>
256
                     Make_Function_Call (Loc,
257
                       Name => Fname,
258
                       Parameter_Associations => New_List (
259
                         Relocate_Node (Tag_Arg),
260
                         New_Reference_To
261
                           (Node (First_Elmt (Access_Disp_Table
262
                                               (Etype (Etype (Act_Constr))))),
263
                            Loc))));
264
               Insert_Action (N, Iface_Tag);
265
            end;
266
         end if;
267
      end if;
268
 
269
      --  Create the call to the actual Constructor function
270
 
271
      Cnstr_Call :=
272
        Make_Function_Call (Loc,
273
          Name                   => New_Occurrence_Of (Act_Constr, Loc),
274
          Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
275
 
276
      --  Establish its controlling tag from the tag passed to the instance
277
      --  The tag may be given by a function call, in which case a temporary
278
      --  should be generated now, to prevent out-of-order insertions during
279
      --  the expansion of that call when stack-checking is enabled.
280
 
281
      if Present (Iface_Tag) then
282
         Set_Controlling_Argument (Cnstr_Call,
283
           New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
284
      else
285
         Remove_Side_Effects (Tag_Arg);
286
         Set_Controlling_Argument (Cnstr_Call,
287
           Relocate_Node (Tag_Arg));
288
      end if;
289
 
290
      --  Rewrite and analyze the call to the instance as a class-wide
291
      --  conversion of the call to the actual constructor.
292
 
293
      Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
294
      Analyze_And_Resolve (N, Etype (Act_Constr));
295
 
296
      --  Do not generate a run-time check on the built object if tag
297
      --  checks are suppressed for the result type or VM_Target /= No_VM
298
 
299
      if Tag_Checks_Suppressed (Etype (Result_Typ))
300
        or else not Tagged_Type_Expansion
301
      then
302
         null;
303
 
304
      --  Generate a class-wide membership test to ensure that the call's tag
305
      --  argument denotes a type within the class. We must keep separate the
306
      --  case in which the Result_Type of the constructor function is a tagged
307
      --  type from the case in which it is an abstract interface because the
308
      --  run-time subprogram required to check these cases differ (and have
309
      --  one difference in their parameters profile).
310
 
311
      --  Call CW_Membership if the Result_Type is a tagged type to look for
312
      --  the tag in the table of ancestor tags.
313
 
314
      elsif not Is_Interface (Result_Typ) then
315
         declare
316
            Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
317
            CW_Test_Node : Node_Id;
318
 
319
         begin
320
            Build_CW_Membership (Loc,
321
              Obj_Tag_Node => Obj_Tag_Node,
322
              Typ_Tag_Node =>
323
                New_Reference_To (
324
                   Node (First_Elmt (Access_Disp_Table (
325
                                       Root_Type (Result_Typ)))), Loc),
326
              Related_Nod => N,
327
              New_Node    => CW_Test_Node);
328
 
329
            Insert_Action (N,
330
              Make_Implicit_If_Statement (N,
331
                Condition =>
332
                  Make_Op_Not (Loc, CW_Test_Node),
333
                Then_Statements =>
334
                  New_List (Make_Raise_Statement (Loc,
335
                              New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
336
         end;
337
 
338
      --  Call IW_Membership test if the Result_Type is an abstract interface
339
      --  to look for the tag in the table of interface tags.
340
 
341
      else
342
         Insert_Action (N,
343
           Make_Implicit_If_Statement (N,
344
             Condition =>
345
               Make_Op_Not (Loc,
346
                 Make_Function_Call (Loc,
347
                    Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
348
                    Parameter_Associations => New_List (
349
                      Make_Attribute_Reference (Loc,
350
                        Prefix         => Duplicate_Subexpr (Tag_Arg),
351
                        Attribute_Name => Name_Address),
352
 
353
                      New_Reference_To (
354
                        Node (First_Elmt (Access_Disp_Table (
355
                                            Root_Type (Result_Typ)))), Loc)))),
356
             Then_Statements =>
357
               New_List (
358
                 Make_Raise_Statement (Loc,
359
                   Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
360
      end if;
361
   end Expand_Dispatching_Constructor_Call;
362
 
363
   ---------------------------
364
   -- Expand_Exception_Call --
365
   ---------------------------
366
 
367
   --  If the function call is not within an exception handler, then the call
368
   --  is replaced by a null string. Otherwise the appropriate routine in
369
   --  Ada.Exceptions is called passing the choice parameter specification
370
   --  from the enclosing handler. If the enclosing handler lacks a choice
371
   --  parameter, then one is supplied.
372
 
373
   procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
374
      Loc : constant Source_Ptr := Sloc (N);
375
      P   : Node_Id;
376
      E   : Entity_Id;
377
 
378
   begin
379
      --  Climb up parents to see if we are in exception handler
380
 
381
      P := Parent (N);
382
      loop
383
         --  Case of not in exception handler, replace by null string
384
 
385
         if No (P) then
386
            Rewrite (N,
387
              Make_String_Literal (Loc,
388
                Strval => ""));
389
            exit;
390
 
391
         --  Case of in exception handler
392
 
393
         elsif Nkind (P) = N_Exception_Handler then
394
 
395
            --  Handler cannot be used for a local raise, and furthermore, this
396
            --  is a violation of the No_Exception_Propagation restriction.
397
 
398
            Set_Local_Raise_Not_OK (P);
399
            Check_Restriction (No_Exception_Propagation, N);
400
 
401
            --  If no choice parameter present, then put one there. Note that
402
            --  we do not need to put it on the entity chain, since no one will
403
            --  be referencing it by normal visibility methods.
404
 
405
            if No (Choice_Parameter (P)) then
406
               E := Make_Temporary (Loc, 'E');
407
               Set_Choice_Parameter (P, E);
408
               Set_Ekind (E, E_Variable);
409
               Set_Etype (E, RTE (RE_Exception_Occurrence));
410
               Set_Scope (E, Current_Scope);
411
            end if;
412
 
413
            Rewrite (N,
414
              Make_Function_Call (Loc,
415
                Name => New_Occurrence_Of (RTE (Ent), Loc),
416
                Parameter_Associations => New_List (
417
                  New_Occurrence_Of (Choice_Parameter (P), Loc))));
418
            exit;
419
 
420
         --  Keep climbing!
421
 
422
         else
423
            P := Parent (P);
424
         end if;
425
      end loop;
426
 
427
      Analyze_And_Resolve (N, Standard_String);
428
   end Expand_Exception_Call;
429
 
430
   ------------------------
431
   -- Expand_Import_Call --
432
   ------------------------
433
 
434
   --  The function call must have a static string as its argument. We create
435
   --  a dummy variable which uses this string as the external name in an
436
   --  Import pragma. The result is then obtained as the address of this
437
   --  dummy variable, converted to the appropriate target type.
438
 
439
   procedure Expand_Import_Call (N : Node_Id) is
440
      Loc : constant Source_Ptr := Sloc (N);
441
      Ent : constant Entity_Id  := Entity (Name (N));
442
      Str : constant Node_Id    := First_Actual (N);
443
      Dum : constant Entity_Id  := Make_Temporary (Loc, 'D');
444
 
445
   begin
446
      Insert_Actions (N, New_List (
447
        Make_Object_Declaration (Loc,
448
          Defining_Identifier => Dum,
449
          Object_Definition   =>
450
            New_Occurrence_Of (Standard_Character, Loc)),
451
 
452
        Make_Pragma (Loc,
453
          Chars => Name_Import,
454
          Pragma_Argument_Associations => New_List (
455
            Make_Pragma_Argument_Association (Loc,
456
              Expression => Make_Identifier (Loc, Name_Ada)),
457
 
458
            Make_Pragma_Argument_Association (Loc,
459
              Expression => Make_Identifier (Loc, Chars (Dum))),
460
 
461
            Make_Pragma_Argument_Association (Loc,
462
              Chars => Name_Link_Name,
463
              Expression => Relocate_Node (Str))))));
464
 
465
      Rewrite (N,
466
        Unchecked_Convert_To (Etype (Ent),
467
          Make_Attribute_Reference (Loc,
468
            Prefix         => Make_Identifier (Loc, Chars (Dum)),
469
            Attribute_Name => Name_Address)));
470
 
471
      Analyze_And_Resolve (N, Etype (Ent));
472
   end Expand_Import_Call;
473
 
474
   ---------------------------
475
   -- Expand_Intrinsic_Call --
476
   ---------------------------
477
 
478
   procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
479
      Nam : Name_Id;
480
 
481
   begin
482
      --  If an external name is specified for the intrinsic, it is handled
483
      --  by the back-end: leave the call node unchanged for now.
484
 
485
      if Present (Interface_Name (E)) then
486
         return;
487
      end if;
488
 
489
      --  If the intrinsic subprogram is generic, gets its original name
490
 
491
      if Present (Parent (E))
492
        and then Present (Generic_Parent (Parent (E)))
493
      then
494
         Nam := Chars (Generic_Parent (Parent (E)));
495
      else
496
         Nam := Chars (E);
497
      end if;
498
 
499
      if Nam = Name_Asm then
500
         Expand_Asm_Call (N);
501
 
502
      elsif Nam = Name_Divide then
503
         Expand_Decimal_Divide_Call (N);
504
 
505
      elsif Nam = Name_Exception_Information then
506
         Expand_Exception_Call (N, RE_Exception_Information);
507
 
508
      elsif Nam = Name_Exception_Message then
509
         Expand_Exception_Call (N, RE_Exception_Message);
510
 
511
      elsif Nam = Name_Exception_Name then
512
         Expand_Exception_Call (N, RE_Exception_Name_Simple);
513
 
514
      elsif Nam = Name_Generic_Dispatching_Constructor then
515
         Expand_Dispatching_Constructor_Call (N);
516
 
517
      elsif Nam = Name_Import_Address
518
              or else
519
            Nam = Name_Import_Largest_Value
520
              or else
521
            Nam = Name_Import_Value
522
      then
523
         Expand_Import_Call (N);
524
 
525
      elsif Nam = Name_Is_Negative then
526
         Expand_Is_Negative (N);
527
 
528
      elsif Nam = Name_Rotate_Left then
529
         Expand_Shift (N, E, N_Op_Rotate_Left);
530
 
531
      elsif Nam = Name_Rotate_Right then
532
         Expand_Shift (N, E, N_Op_Rotate_Right);
533
 
534
      elsif Nam = Name_Shift_Left then
535
         Expand_Shift (N, E, N_Op_Shift_Left);
536
 
537
      elsif Nam = Name_Shift_Right then
538
         Expand_Shift (N, E, N_Op_Shift_Right);
539
 
540
      elsif Nam = Name_Shift_Right_Arithmetic then
541
         Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
542
 
543
      elsif Nam = Name_Unchecked_Conversion then
544
         Expand_Unc_Conversion (N, E);
545
 
546
      elsif Nam = Name_Unchecked_Deallocation then
547
         Expand_Unc_Deallocation (N);
548
 
549
      elsif Nam = Name_To_Address then
550
         Expand_To_Address (N);
551
 
552
      elsif Nam = Name_To_Pointer then
553
         Expand_To_Pointer (N);
554
 
555
      elsif Nam = Name_File
556
        or else Nam = Name_Line
557
        or else Nam = Name_Source_Location
558
        or else Nam = Name_Enclosing_Entity
559
      then
560
         Expand_Source_Info (N, Nam);
561
 
562
         --  If we have a renaming, expand the call to the original operation,
563
         --  which must itself be intrinsic, since renaming requires matching
564
         --  conventions and this has already been checked.
565
 
566
      elsif Present (Alias (E)) then
567
         Expand_Intrinsic_Call (N,  Alias (E));
568
 
569
      elsif Nkind (N) in N_Binary_Op then
570
         Expand_Binary_Operator_Call (N);
571
 
572
         --  The only other case is where an external name was specified,
573
         --  since this is the only way that an otherwise unrecognized
574
         --  name could escape the checking in Sem_Prag. Nothing needs
575
         --  to be done in such a case, since we pass such a call to the
576
         --  back end unchanged.
577
 
578
      else
579
         null;
580
      end if;
581
   end Expand_Intrinsic_Call;
582
 
583
   ------------------------
584
   -- Expand_Is_Negative --
585
   ------------------------
586
 
587
   procedure Expand_Is_Negative (N : Node_Id) is
588
      Loc   : constant Source_Ptr := Sloc (N);
589
      Opnd  : constant Node_Id    := Relocate_Node (First_Actual (N));
590
 
591
   begin
592
 
593
      --  We replace the function call by the following expression
594
 
595
      --    if Opnd < 0.0 then
596
      --       True
597
      --    else
598
      --       if Opnd > 0.0 then
599
      --          False;
600
      --       else
601
      --          Float_Unsigned!(Float (Opnd)) /= 0
602
      --       end if;
603
      --    end if;
604
 
605
      Rewrite (N,
606
        Make_Conditional_Expression (Loc,
607
          Expressions => New_List (
608
            Make_Op_Lt (Loc,
609
              Left_Opnd  => Duplicate_Subexpr (Opnd),
610
              Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
611
 
612
            New_Occurrence_Of (Standard_True, Loc),
613
 
614
            Make_Conditional_Expression (Loc,
615
             Expressions => New_List (
616
               Make_Op_Gt (Loc,
617
                 Left_Opnd  => Duplicate_Subexpr_No_Checks (Opnd),
618
                 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
619
 
620
               New_Occurrence_Of (Standard_False, Loc),
621
 
622
                Make_Op_Ne (Loc,
623
                  Left_Opnd =>
624
                    Unchecked_Convert_To
625
                      (RTE (RE_Float_Unsigned),
626
                       Convert_To
627
                         (Standard_Float,
628
                          Duplicate_Subexpr_No_Checks (Opnd))),
629
                  Right_Opnd =>
630
                    Make_Integer_Literal (Loc, 0)))))));
631
 
632
      Analyze_And_Resolve (N, Standard_Boolean);
633
   end Expand_Is_Negative;
634
 
635
   ------------------
636
   -- Expand_Shift --
637
   ------------------
638
 
639
   --  This procedure is used to convert a call to a shift function to the
640
   --  corresponding operator node. This conversion is not done by the usual
641
   --  circuit for converting calls to operator functions (e.g. "+"(1,2)) to
642
   --  operator nodes, because shifts are not predefined operators.
643
 
644
   --  As a result, whenever a shift is used in the source program, it will
645
   --  remain as a call until converted by this routine to the operator node
646
   --  form which Gigi is expecting to see.
647
 
648
   --  Note: it is possible for the expander to generate shift operator nodes
649
   --  directly, which will be analyzed in the normal manner by calling Analyze
650
   --  and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
651
 
652
   procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
653
      Loc   : constant Source_Ptr := Sloc (N);
654
      Typ   : constant Entity_Id  := Etype (N);
655
      Left  : constant Node_Id    := First_Actual (N);
656
      Right : constant Node_Id    := Next_Actual (Left);
657
      Ltyp  : constant Node_Id    := Etype (Left);
658
      Rtyp  : constant Node_Id    := Etype (Right);
659
      Snode : Node_Id;
660
 
661
   begin
662
      Snode := New_Node (K, Loc);
663
      Set_Left_Opnd  (Snode, Relocate_Node (Left));
664
      Set_Right_Opnd (Snode, Relocate_Node (Right));
665
      Set_Chars      (Snode, Chars (E));
666
      Set_Etype      (Snode, Base_Type (Typ));
667
      Set_Entity     (Snode, E);
668
 
669
      if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
670
        and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
671
      then
672
         Set_Shift_Count_OK (Snode, True);
673
      end if;
674
 
675
      --  Do the rewrite. Note that we don't call Analyze and Resolve on
676
      --  this node, because it already got analyzed and resolved when
677
      --  it was a function call!
678
 
679
      Rewrite (N, Snode);
680
      Set_Analyzed (N);
681
   end Expand_Shift;
682
 
683
   ------------------------
684
   -- Expand_Source_Info --
685
   ------------------------
686
 
687
   procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
688
      Loc : constant Source_Ptr := Sloc (N);
689
      Ent : Entity_Id;
690
 
691
      procedure Write_Entity_Name (E : Entity_Id);
692
      --  Recursive procedure to construct string for qualified name of
693
      --  enclosing program unit. The qualification stops at an enclosing
694
      --  scope has no source name (block or loop). If entity is a subprogram
695
      --  instance, skip enclosing wrapper package.
696
 
697
      -----------------------
698
      -- Write_Entity_Name --
699
      -----------------------
700
 
701
      procedure Write_Entity_Name (E : Entity_Id) is
702
         SDef : Source_Ptr;
703
         TDef : constant Source_Buffer_Ptr :=
704
                  Source_Text (Get_Source_File_Index (Sloc (E)));
705
 
706
      begin
707
         --  Nothing to do if at outer level
708
 
709
         if Scope (E) = Standard_Standard then
710
            null;
711
 
712
         --  If scope comes from source, write its name
713
 
714
         elsif Comes_From_Source (Scope (E)) then
715
            Write_Entity_Name (Scope (E));
716
            Add_Char_To_Name_Buffer ('.');
717
 
718
         --  If in wrapper package skip past it
719
 
720
         elsif Is_Wrapper_Package (Scope (E)) then
721
            Write_Entity_Name (Scope (Scope (E)));
722
            Add_Char_To_Name_Buffer ('.');
723
 
724
         --  Otherwise nothing to output (happens in unnamed block statements)
725
 
726
         else
727
            null;
728
         end if;
729
 
730
         --  Loop to output the name
731
 
732
         --  is this right wrt wide char encodings ??? (no!)
733
 
734
         SDef := Sloc (E);
735
         while TDef (SDef) in '0' .. '9'
736
           or else TDef (SDef) >= 'A'
737
           or else TDef (SDef) = ASCII.ESC
738
         loop
739
            Add_Char_To_Name_Buffer (TDef (SDef));
740
            SDef := SDef + 1;
741
         end loop;
742
      end Write_Entity_Name;
743
 
744
   --  Start of processing for Expand_Source_Info
745
 
746
   begin
747
      --  Integer cases
748
 
749
      if Nam = Name_Line then
750
         Rewrite (N,
751
           Make_Integer_Literal (Loc,
752
             Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
753
         Analyze_And_Resolve (N, Standard_Positive);
754
 
755
      --  String cases
756
 
757
      else
758
         Name_Len := 0;
759
 
760
         case Nam is
761
            when Name_File =>
762
               Get_Decoded_Name_String
763
                 (Reference_Name (Get_Source_File_Index (Loc)));
764
 
765
            when Name_Source_Location =>
766
               Build_Location_String (Loc);
767
 
768
            when Name_Enclosing_Entity =>
769
 
770
               --  Skip enclosing blocks to reach enclosing unit
771
 
772
               Ent := Current_Scope;
773
               while Present (Ent) loop
774
                  exit when Ekind (Ent) /= E_Block
775
                    and then Ekind (Ent) /= E_Loop;
776
                  Ent := Scope (Ent);
777
               end loop;
778
 
779
               --  Ent now points to the relevant defining entity
780
 
781
               Write_Entity_Name (Ent);
782
 
783
            when others =>
784
               raise Program_Error;
785
         end case;
786
 
787
         Rewrite (N,
788
           Make_String_Literal (Loc,
789
             Strval => String_From_Name_Buffer));
790
         Analyze_And_Resolve (N, Standard_String);
791
      end if;
792
 
793
      Set_Is_Static_Expression (N);
794
   end Expand_Source_Info;
795
 
796
   ---------------------------
797
   -- Expand_Unc_Conversion --
798
   ---------------------------
799
 
800
   procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
801
      Func : constant Entity_Id  := Entity (Name (N));
802
      Conv : Node_Id;
803
      Ftyp : Entity_Id;
804
      Ttyp : Entity_Id;
805
 
806
   begin
807
      --  Rewrite as unchecked conversion node. Note that we must convert
808
      --  the operand to the formal type of the input parameter of the
809
      --  function, so that the resulting N_Unchecked_Type_Conversion
810
      --  call indicates the correct types for Gigi.
811
 
812
      --  Right now, we only do this if a scalar type is involved. It is
813
      --  not clear if it is needed in other cases. If we do attempt to
814
      --  do the conversion unconditionally, it crashes 3411-018. To be
815
      --  investigated further ???
816
 
817
      Conv := Relocate_Node (First_Actual (N));
818
      Ftyp := Etype (First_Formal (Func));
819
 
820
      if Is_Scalar_Type (Ftyp) then
821
         Conv := Convert_To (Ftyp, Conv);
822
         Set_Parent (Conv, N);
823
         Analyze_And_Resolve (Conv);
824
      end if;
825
 
826
      --  The instantiation of Unchecked_Conversion creates a wrapper package,
827
      --  and the target type is declared as a subtype of the actual. Recover
828
      --  the actual, which is the subtype indic. in the subtype declaration
829
      --  for the target type. This is semantically correct, and avoids
830
      --  anomalies with access subtypes. For entities, leave type as is.
831
 
832
      --  We do the analysis here, because we do not want the compiler
833
      --  to try to optimize or otherwise reorganize the unchecked
834
      --  conversion node.
835
 
836
      Ttyp := Etype (E);
837
 
838
      if Is_Entity_Name (Conv) then
839
         null;
840
 
841
      elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then
842
         Ttyp := Entity (Subtype_Indication (Parent (Etype (E))));
843
 
844
      elsif Is_Itype (Ttyp) then
845
         Ttyp :=
846
           Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp)));
847
      else
848
         raise Program_Error;
849
      end if;
850
 
851
      Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
852
      Set_Etype (N, Ttyp);
853
      Set_Analyzed (N);
854
 
855
      if Nkind (N) = N_Unchecked_Type_Conversion then
856
         Expand_N_Unchecked_Type_Conversion (N);
857
      end if;
858
   end Expand_Unc_Conversion;
859
 
860
   -----------------------------
861
   -- Expand_Unc_Deallocation --
862
   -----------------------------
863
 
864
   --  Generate the following Code :
865
 
866
   --    if Arg /= null then
867
   --     <Finalize_Call> (.., T'Class(Arg.all), ..);  -- for controlled types
868
   --       Free (Arg);
869
   --       Arg := Null;
870
   --    end if;
871
 
872
   --  For a task, we also generate a call to Free_Task to ensure that the
873
   --  task itself is freed if it is terminated, ditto for a simple protected
874
   --  object, with a call to Finalize_Protection. For composite types that
875
   --  have tasks or simple protected objects as components, we traverse the
876
   --  structures to find and terminate those components.
877
 
878
   procedure Expand_Unc_Deallocation (N : Node_Id) is
879
      Arg       : constant Node_Id    := First_Actual (N);
880
      Loc       : constant Source_Ptr := Sloc (N);
881
      Typ       : constant Entity_Id  := Etype (Arg);
882
      Desig_T   : constant Entity_Id  := Designated_Type (Typ);
883
      Rtyp      : constant Entity_Id  := Underlying_Type (Root_Type (Typ));
884
      Pool      : constant Entity_Id  := Associated_Storage_Pool (Rtyp);
885
      Stmts     : constant List_Id    := New_List;
886
      Needs_Fin : constant Boolean    := Needs_Finalization (Desig_T);
887
 
888
      Finalizer_Data  : Finalization_Exception_Data;
889
 
890
      Blk        : Node_Id := Empty;
891
      Deref      : Node_Id;
892
      Final_Code : List_Id;
893
      Free_Arg   : Node_Id;
894
      Free_Node  : Node_Id;
895
      Gen_Code   : Node_Id;
896
 
897
      Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
898
      --  This captures whether we know the argument to be non-null so that
899
      --  we can avoid the test. The reason that we need to capture this is
900
      --  that we analyze some generated statements before properly attaching
901
      --  them to the tree, and that can disturb current value settings.
902
 
903
   begin
904
      --  Nothing to do if we know the argument is null
905
 
906
      if Known_Null (N) then
907
         return;
908
      end if;
909
 
910
      --  Processing for pointer to controlled type
911
 
912
      if Needs_Fin then
913
         Deref :=
914
           Make_Explicit_Dereference (Loc,
915
             Prefix => Duplicate_Subexpr_No_Checks (Arg));
916
 
917
         --  If the type is tagged, then we must force dispatching on the
918
         --  finalization call because the designated type may not be the
919
         --  actual type of the object.
920
 
921
         if Is_Tagged_Type (Desig_T)
922
           and then not Is_Class_Wide_Type (Desig_T)
923
         then
924
            Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
925
 
926
         elsif not Is_Tagged_Type (Desig_T) then
927
 
928
            --  Set type of result, to force a conversion when needed (see
929
            --  exp_ch7, Convert_View), given that Deep_Finalize may be
930
            --  inherited from the parent type, and we need the type of the
931
            --  expression to see whether the conversion is in fact needed.
932
 
933
            Set_Etype (Deref, Desig_T);
934
         end if;
935
 
936
         --  The finalization call is expanded wrapped in a block to catch any
937
         --  possible exception. If an exception does occur, then Program_Error
938
         --  must be raised following the freeing of the object and its removal
939
         --  from the finalization collection's list. We set a flag to record
940
         --  that an exception was raised, and save its occurrence for use in
941
         --  the later raise.
942
         --
943
         --  Generate:
944
         --    Abort  : constant Boolean :=
945
         --               Exception_Occurrence (Get_Current_Excep.all.all) =
946
         --                 Standard'Abort_Signal'Identity;
947
         --      <or>
948
         --    Abort  : constant Boolean := False;  --  no abort
949
 
950
         --    E      : Exception_Occurrence;
951
         --    Raised : Boolean := False;
952
         --
953
         --    begin
954
         --       [Deep_]Finalize (Obj);
955
         --    exception
956
         --       when others =>
957
         --          Raised := True;
958
         --          Save_Occurrence (E, Get_Current_Excep.all.all);
959
         --    end;
960
 
961
         Build_Object_Declarations (Finalizer_Data, Stmts, Loc);
962
 
963
         Final_Code := New_List (
964
           Make_Block_Statement (Loc,
965
             Handled_Statement_Sequence =>
966
               Make_Handled_Sequence_Of_Statements (Loc,
967
                 Statements         => New_List (
968
                   Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)),
969
                 Exception_Handlers => New_List (
970
                   Build_Exception_Handler (Finalizer_Data)))));
971
 
972
         --  For .NET/JVM, detach the object from the containing finalization
973
         --  collection before finalizing it.
974
 
975
         if VM_Target /= No_VM and then Is_Controlled (Desig_T) then
976
            Prepend_To (Final_Code,
977
              Make_Detach_Call (New_Copy_Tree (Arg)));
978
         end if;
979
 
980
         --  If aborts are allowed, then the finalization code must be
981
         --  protected by an abort defer/undefer pair.
982
 
983
         if Abort_Allowed then
984
            Prepend_To (Final_Code,
985
              Build_Runtime_Call (Loc, RE_Abort_Defer));
986
 
987
            Blk :=
988
              Make_Block_Statement (Loc, Handled_Statement_Sequence =>
989
                Make_Handled_Sequence_Of_Statements (Loc,
990
                  Statements  => Final_Code,
991
                  At_End_Proc =>
992
                    New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
993
 
994
            Append (Blk, Stmts);
995
         else
996
            Append_List_To (Stmts, Final_Code);
997
         end if;
998
      end if;
999
 
1000
      --  For a task type, call Free_Task before freeing the ATCB
1001
 
1002
      if Is_Task_Type (Desig_T) then
1003
         declare
1004
            Stat : Node_Id := Prev (N);
1005
            Nam1 : Node_Id;
1006
            Nam2 : Node_Id;
1007
 
1008
         begin
1009
            --  An Abort followed by a Free will not do what the user expects,
1010
            --  because the abort is not immediate. This is worth a warning.
1011
 
1012
            while Present (Stat)
1013
              and then not Comes_From_Source (Original_Node (Stat))
1014
            loop
1015
               Prev (Stat);
1016
            end loop;
1017
 
1018
            if Present (Stat)
1019
              and then Nkind (Original_Node (Stat)) = N_Abort_Statement
1020
            then
1021
               Stat := Original_Node (Stat);
1022
               Nam1 := First (Names (Stat));
1023
               Nam2 := Original_Node (First (Parameter_Associations (N)));
1024
 
1025
               if Nkind (Nam1) = N_Explicit_Dereference
1026
                 and then Is_Entity_Name (Prefix (Nam1))
1027
                 and then Is_Entity_Name (Nam2)
1028
                 and then Entity (Prefix (Nam1)) = Entity (Nam2)
1029
               then
1030
                  Error_Msg_N ("abort may take time to complete?", N);
1031
                  Error_Msg_N ("\deallocation might have no effect?", N);
1032
                  Error_Msg_N ("\safer to wait for termination.?", N);
1033
               end if;
1034
            end if;
1035
         end;
1036
 
1037
         Append_To
1038
           (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
1039
 
1040
      --  For composite types that contain tasks, recurse over the structure
1041
      --  to build the selectors for the task subcomponents.
1042
 
1043
      elsif Has_Task (Desig_T) then
1044
         if Is_Record_Type (Desig_T) then
1045
            Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
1046
 
1047
         elsif Is_Array_Type (Desig_T) then
1048
            Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
1049
         end if;
1050
      end if;
1051
 
1052
      --  Same for simple protected types. Eventually call Finalize_Protection
1053
      --  before freeing the PO for each protected component.
1054
 
1055
      if Is_Simple_Protected_Type (Desig_T) then
1056
         Append_To (Stmts,
1057
           Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
1058
 
1059
      elsif Has_Simple_Protected_Object (Desig_T) then
1060
         if Is_Record_Type (Desig_T) then
1061
            Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
1062
         elsif Is_Array_Type (Desig_T) then
1063
            Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
1064
         end if;
1065
      end if;
1066
 
1067
      --  Normal processing for non-controlled types
1068
 
1069
      Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
1070
      Free_Node := Make_Free_Statement (Loc, Empty);
1071
      Append_To (Stmts, Free_Node);
1072
      Set_Storage_Pool (Free_Node, Pool);
1073
 
1074
      --  Attach to tree before analysis of generated subtypes below
1075
 
1076
      Set_Parent (Stmts, Parent (N));
1077
 
1078
      --  Deal with storage pool
1079
 
1080
      if Present (Pool) then
1081
 
1082
         --  Freeing the secondary stack is meaningless
1083
 
1084
         if Is_RTE (Pool, RE_SS_Pool) then
1085
            null;
1086
 
1087
         --  If the pool object is of a simple storage pool type, then attempt
1088
         --  to locate the type's Deallocate procedure, if any, and set the
1089
         --  free operation's procedure to call. If the type doesn't have a
1090
         --  Deallocate (which is allowed), then the actual will simply be set
1091
         --  to null.
1092
 
1093
         elsif Present (Get_Rep_Pragma
1094
                          (Etype (Pool), Name_Simple_Storage_Pool_Type))
1095
         then
1096
            declare
1097
               Pool_Type  : constant Entity_Id := Base_Type (Etype (Pool));
1098
               Dealloc_Op : Entity_Id;
1099
            begin
1100
               Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
1101
               while Present (Dealloc_Op) loop
1102
                  if Scope (Dealloc_Op) = Scope (Pool_Type)
1103
                    and then Present (First_Formal (Dealloc_Op))
1104
                    and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
1105
                  then
1106
                     Set_Procedure_To_Call (Free_Node, Dealloc_Op);
1107
                     exit;
1108
                  else
1109
                     Dealloc_Op := Homonym (Dealloc_Op);
1110
                  end if;
1111
               end loop;
1112
            end;
1113
 
1114
         --  Case of a class-wide pool type: make a dispatching call to
1115
         --  Deallocate through the class-wide Deallocate_Any.
1116
 
1117
         elsif Is_Class_Wide_Type (Etype (Pool)) then
1118
            Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any));
1119
 
1120
         --  Case of a specific pool type: make a statically bound call
1121
 
1122
         else
1123
            Set_Procedure_To_Call (Free_Node,
1124
              Find_Prim_Op (Etype (Pool), Name_Deallocate));
1125
         end if;
1126
      end if;
1127
 
1128
      if Present (Procedure_To_Call (Free_Node)) then
1129
 
1130
         --  For all cases of a Deallocate call, the back-end needs to be able
1131
         --  to compute the size of the object being freed. This may require
1132
         --  some adjustments for objects of dynamic size.
1133
         --
1134
         --  If the type is class wide, we generate an implicit type with the
1135
         --  right dynamic size, so that the deallocate call gets the right
1136
         --  size parameter computed by GIGI. Same for an access to
1137
         --  unconstrained packed array.
1138
 
1139
         if Is_Class_Wide_Type (Desig_T)
1140
           or else
1141
            (Is_Array_Type (Desig_T)
1142
              and then not Is_Constrained (Desig_T)
1143
              and then Is_Packed (Desig_T))
1144
         then
1145
            declare
1146
               Deref    : constant Node_Id :=
1147
                            Make_Explicit_Dereference (Loc,
1148
                              Duplicate_Subexpr_No_Checks (Arg));
1149
               D_Subtyp : Node_Id;
1150
               D_Type   : Entity_Id;
1151
 
1152
            begin
1153
               --  Perform minor decoration as it is needed by the side effect
1154
               --  removal mechanism.
1155
 
1156
               Set_Etype  (Deref, Desig_T);
1157
               Set_Parent (Deref, Free_Node);
1158
               D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
1159
 
1160
               if Nkind (D_Subtyp) in N_Has_Entity then
1161
                  D_Type := Entity (D_Subtyp);
1162
 
1163
               else
1164
                  D_Type := Make_Temporary (Loc, 'A');
1165
                  Insert_Action (Deref,
1166
                    Make_Subtype_Declaration (Loc,
1167
                      Defining_Identifier => D_Type,
1168
                      Subtype_Indication  => D_Subtyp));
1169
               end if;
1170
 
1171
               --  Force freezing at the point of the dereference. For the
1172
               --  class wide case, this avoids having the subtype frozen
1173
               --  before the equivalent type.
1174
 
1175
               Freeze_Itype (D_Type, Deref);
1176
 
1177
               Set_Actual_Designated_Subtype (Free_Node, D_Type);
1178
            end;
1179
 
1180
         end if;
1181
      end if;
1182
 
1183
      --  Ada 2005 (AI-251): In case of abstract interface type we must
1184
      --  displace the pointer to reference the base of the object to
1185
      --  deallocate its memory, unless we're targetting a VM, in which case
1186
      --  no special processing is required.
1187
 
1188
      --  Generate:
1189
      --    free (Base_Address (Obj_Ptr))
1190
 
1191
      if Is_Interface (Directly_Designated_Type (Typ))
1192
        and then Tagged_Type_Expansion
1193
      then
1194
         Set_Expression (Free_Node,
1195
           Unchecked_Convert_To (Typ,
1196
             Make_Function_Call (Loc,
1197
               Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1198
               Parameter_Associations => New_List (
1199
                 Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
1200
 
1201
      --  Generate:
1202
      --    free (Obj_Ptr)
1203
 
1204
      else
1205
         Set_Expression (Free_Node, Free_Arg);
1206
      end if;
1207
 
1208
      --  Only remaining step is to set result to null, or generate a raise of
1209
      --  Constraint_Error if the target object is "not null".
1210
 
1211
      if Can_Never_Be_Null (Etype (Arg)) then
1212
         Append_To (Stmts,
1213
           Make_Raise_Constraint_Error (Loc,
1214
             Reason => CE_Access_Check_Failed));
1215
 
1216
      else
1217
         declare
1218
            Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
1219
         begin
1220
            Set_Assignment_OK (Lhs);
1221
            Append_To (Stmts,
1222
              Make_Assignment_Statement (Loc,
1223
                Name       => Lhs,
1224
                Expression => Make_Null (Loc)));
1225
         end;
1226
      end if;
1227
 
1228
      --  Generate a test of whether any earlier finalization raised an
1229
      --  exception, and in that case raise Program_Error with the previous
1230
      --  exception occurrence.
1231
 
1232
      --  Generate:
1233
      --    if Raised and then not Abort then
1234
      --       raise Program_Error;                  --  for .NET and
1235
      --                                             --  restricted RTS
1236
      --         <or>
1237
      --       Raise_From_Controlled_Operation (E);  --  all other cases
1238
      --    end if;
1239
 
1240
      if Needs_Fin then
1241
         Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
1242
      end if;
1243
 
1244
      --  If we know the argument is non-null, then make a block statement
1245
      --  that contains the required statements, no need for a test.
1246
 
1247
      if Arg_Known_Non_Null then
1248
         Gen_Code :=
1249
           Make_Block_Statement (Loc,
1250
             Handled_Statement_Sequence =>
1251
               Make_Handled_Sequence_Of_Statements (Loc,
1252
             Statements => Stmts));
1253
 
1254
      --  If the argument may be null, wrap the statements inside an IF that
1255
      --  does an explicit test to exclude the null case.
1256
 
1257
      else
1258
         Gen_Code :=
1259
           Make_Implicit_If_Statement (N,
1260
             Condition =>
1261
               Make_Op_Ne (Loc,
1262
                 Left_Opnd  => Duplicate_Subexpr (Arg),
1263
                 Right_Opnd => Make_Null (Loc)),
1264
             Then_Statements => Stmts);
1265
      end if;
1266
 
1267
      --  Rewrite the call
1268
 
1269
      Rewrite (N, Gen_Code);
1270
      Analyze (N);
1271
 
1272
      --  If we generated a block with an At_End_Proc, expand the exception
1273
      --  handler. We need to wait until after everything else is analyzed.
1274
 
1275
      if Present (Blk) then
1276
         Expand_At_End_Handler
1277
           (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
1278
      end if;
1279
   end Expand_Unc_Deallocation;
1280
 
1281
   -----------------------
1282
   -- Expand_To_Address --
1283
   -----------------------
1284
 
1285
   procedure Expand_To_Address (N : Node_Id) is
1286
      Loc : constant Source_Ptr := Sloc (N);
1287
      Arg : constant Node_Id := First_Actual (N);
1288
      Obj : Node_Id;
1289
 
1290
   begin
1291
      Remove_Side_Effects (Arg);
1292
 
1293
      Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
1294
 
1295
      Rewrite (N,
1296
        Make_Conditional_Expression (Loc,
1297
          Expressions => New_List (
1298
            Make_Op_Eq (Loc,
1299
              Left_Opnd => New_Copy_Tree (Arg),
1300
              Right_Opnd => Make_Null (Loc)),
1301
            New_Occurrence_Of (RTE (RE_Null_Address), Loc),
1302
            Make_Attribute_Reference (Loc,
1303
              Prefix         => Obj,
1304
              Attribute_Name => Name_Address))));
1305
 
1306
      Analyze_And_Resolve (N, RTE (RE_Address));
1307
   end Expand_To_Address;
1308
 
1309
   -----------------------
1310
   -- Expand_To_Pointer --
1311
   -----------------------
1312
 
1313
   procedure Expand_To_Pointer (N : Node_Id) is
1314
      Arg : constant Node_Id := First_Actual (N);
1315
 
1316
   begin
1317
      Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
1318
      Analyze (N);
1319
   end Expand_To_Pointer;
1320
 
1321
end Exp_Intr;

powered by: WebSVN 2.1.0

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