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

Subversion Repositories openrisc_2011-10-31

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                               T B U I L D                                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Einfo;    use Einfo;
28
with Elists;   use Elists;
29
with Lib;      use Lib;
30
with Nlists;   use Nlists;
31
with Nmake;    use Nmake;
32
with Opt;      use Opt;
33
with Restrict; use Restrict;
34
with Rident;   use Rident;
35
with Sem_Aux;  use Sem_Aux;
36
with Snames;   use Snames;
37
with Stand;    use Stand;
38
with Stringt;  use Stringt;
39
with Uintp;    use Uintp;
40
 
41
package body Tbuild is
42
 
43
   -----------------------
44
   -- Local Subprograms --
45
   -----------------------
46
 
47
   procedure Add_Unique_Serial_Number;
48
   --  Add a unique serialization to the string in the Name_Buffer. This
49
   --  consists of a unit specific serial number, and b/s for body/spec.
50
 
51
   ------------------------------
52
   -- Add_Unique_Serial_Number --
53
   ------------------------------
54
 
55
   Config_Serial_Number : Nat := 0;
56
   --  Counter for use in config pragmas, see comment below
57
 
58
   procedure Add_Unique_Serial_Number is
59
   begin
60
      --  If we are analyzing configuration pragmas, Cunit (Main_Unit) will
61
      --  not be set yet. This happens for example when analyzing static
62
      --  string expressions in configuration pragmas. For this case, we
63
      --  just maintain a local counter, defined above and we do not need
64
      --  to add a b or s indication in this case.
65
 
66
      if No (Cunit (Current_Sem_Unit)) then
67
         Config_Serial_Number := Config_Serial_Number + 1;
68
         Add_Nat_To_Name_Buffer (Config_Serial_Number);
69
         return;
70
 
71
      --  Normal case, within a unit
72
 
73
      else
74
         declare
75
            Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
76
 
77
         begin
78
            Add_Nat_To_Name_Buffer (Increment_Serial_Number);
79
 
80
            --  Add either b or s, depending on whether current unit is a spec
81
            --  or a body. This is needed because we may generate the same name
82
            --  in a spec and a body otherwise.
83
 
84
            Name_Len := Name_Len + 1;
85
 
86
            if Nkind (Unit_Node) = N_Package_Declaration
87
              or else Nkind (Unit_Node) = N_Subprogram_Declaration
88
              or else Nkind (Unit_Node) in N_Generic_Declaration
89
            then
90
               Name_Buffer (Name_Len) := 's';
91
            else
92
               Name_Buffer (Name_Len) := 'b';
93
            end if;
94
         end;
95
      end if;
96
   end Add_Unique_Serial_Number;
97
 
98
   ----------------
99
   -- Checks_Off --
100
   ----------------
101
 
102
   function Checks_Off (N : Node_Id) return Node_Id is
103
   begin
104
      return
105
        Make_Unchecked_Expression (Sloc (N),
106
          Expression => N);
107
   end Checks_Off;
108
 
109
   ----------------
110
   -- Convert_To --
111
   ----------------
112
 
113
   function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
114
      Result : Node_Id;
115
 
116
   begin
117
      if Present (Etype (Expr))
118
        and then (Etype (Expr)) = Typ
119
      then
120
         return Relocate_Node (Expr);
121
      else
122
         Result :=
123
           Make_Type_Conversion (Sloc (Expr),
124
             Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
125
             Expression => Relocate_Node (Expr));
126
 
127
         Set_Etype (Result, Typ);
128
         return Result;
129
      end if;
130
   end Convert_To;
131
 
132
   ------------------
133
   -- Discard_List --
134
   ------------------
135
 
136
   procedure Discard_List (L : List_Id) is
137
      pragma Warnings (Off, L);
138
   begin
139
      null;
140
   end Discard_List;
141
 
142
   ------------------
143
   -- Discard_Node --
144
   ------------------
145
 
146
   procedure Discard_Node (N : Node_Or_Entity_Id) is
147
      pragma Warnings (Off, N);
148
   begin
149
      null;
150
   end Discard_Node;
151
 
152
   -------------------------------------------
153
   -- Make_Byte_Aligned_Attribute_Reference --
154
   -------------------------------------------
155
 
156
   function Make_Byte_Aligned_Attribute_Reference
157
     (Sloc           : Source_Ptr;
158
      Prefix         : Node_Id;
159
      Attribute_Name : Name_Id)
160
      return           Node_Id
161
   is
162
      N : constant Node_Id :=
163
            Make_Attribute_Reference (Sloc,
164
              Prefix        => Prefix,
165
              Attribute_Name => Attribute_Name);
166
 
167
   begin
168
      pragma Assert (Attribute_Name = Name_Address
169
                       or else
170
                     Attribute_Name = Name_Unrestricted_Access);
171
      Set_Must_Be_Byte_Aligned (N, True);
172
      return N;
173
   end Make_Byte_Aligned_Attribute_Reference;
174
 
175
   --------------------
176
   -- Make_DT_Access --
177
   --------------------
178
 
179
   function Make_DT_Access
180
     (Loc : Source_Ptr;
181
      Rec : Node_Id;
182
      Typ : Entity_Id) return Node_Id
183
   is
184
      Full_Type : Entity_Id := Typ;
185
 
186
   begin
187
      if Is_Private_Type (Typ) then
188
         Full_Type := Underlying_Type (Typ);
189
      end if;
190
 
191
      return
192
        Unchecked_Convert_To (
193
          New_Occurrence_Of
194
            (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
195
          Make_Selected_Component (Loc,
196
            Prefix => New_Copy (Rec),
197
            Selector_Name =>
198
              New_Reference_To (First_Tag_Component (Full_Type), Loc)));
199
   end Make_DT_Access;
200
 
201
   -------------------------------------
202
   -- Make_Implicit_Exception_Handler --
203
   -------------------------------------
204
 
205
   function Make_Implicit_Exception_Handler
206
     (Sloc              : Source_Ptr;
207
      Choice_Parameter  : Node_Id := Empty;
208
      Exception_Choices : List_Id;
209
      Statements        : List_Id) return Node_Id
210
   is
211
      Handler : Node_Id;
212
      Loc     : Source_Ptr;
213
 
214
   begin
215
      --  Set the source location only when debugging the expanded code
216
 
217
      --  When debugging the source code directly, we do not want the compiler
218
      --  to associate this implicit exception handler with any specific source
219
      --  line, because it can potentially confuse the debugger. The most
220
      --  damaging situation would arise when the debugger tries to insert a
221
      --  breakpoint at a certain line. If the code of the associated implicit
222
      --  exception handler is generated before the code of that line, then the
223
      --  debugger will end up inserting the breakpoint inside the exception
224
      --  handler, rather than the code the user intended to break on. As a
225
      --  result, it is likely that the program will not hit the breakpoint
226
      --  as expected.
227
 
228
      if Debug_Generated_Code then
229
         Loc := Sloc;
230
      else
231
         Loc := No_Location;
232
      end if;
233
 
234
      Handler :=
235
        Make_Exception_Handler
236
          (Loc, Choice_Parameter, Exception_Choices, Statements);
237
      Set_Local_Raise_Statements (Handler, No_Elist);
238
      return Handler;
239
   end Make_Implicit_Exception_Handler;
240
 
241
   --------------------------------
242
   -- Make_Implicit_If_Statement --
243
   --------------------------------
244
 
245
   function Make_Implicit_If_Statement
246
     (Node            : Node_Id;
247
      Condition       : Node_Id;
248
      Then_Statements : List_Id;
249
      Elsif_Parts     : List_Id := No_List;
250
      Else_Statements : List_Id := No_List) return Node_Id
251
   is
252
   begin
253
      Check_Restriction (No_Implicit_Conditionals, Node);
254
 
255
      return Make_If_Statement (Sloc (Node),
256
        Condition,
257
        Then_Statements,
258
        Elsif_Parts,
259
        Else_Statements);
260
   end Make_Implicit_If_Statement;
261
 
262
   -------------------------------------
263
   -- Make_Implicit_Label_Declaration --
264
   -------------------------------------
265
 
266
   function Make_Implicit_Label_Declaration
267
     (Loc                 : Source_Ptr;
268
      Defining_Identifier : Node_Id;
269
      Label_Construct     : Node_Id) return Node_Id
270
   is
271
      N : constant Node_Id :=
272
            Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
273
   begin
274
      Set_Label_Construct (N, Label_Construct);
275
      return N;
276
   end Make_Implicit_Label_Declaration;
277
 
278
   ----------------------------------
279
   -- Make_Implicit_Loop_Statement --
280
   ----------------------------------
281
 
282
   function Make_Implicit_Loop_Statement
283
     (Node                   : Node_Id;
284
      Statements             : List_Id;
285
      Identifier             : Node_Id := Empty;
286
      Iteration_Scheme       : Node_Id := Empty;
287
      Has_Created_Identifier : Boolean := False;
288
      End_Label              : Node_Id := Empty) return Node_Id
289
   is
290
   begin
291
      Check_Restriction (No_Implicit_Loops, Node);
292
 
293
      if Present (Iteration_Scheme)
294
        and then Present (Condition (Iteration_Scheme))
295
      then
296
         Check_Restriction (No_Implicit_Conditionals, Node);
297
      end if;
298
 
299
      return Make_Loop_Statement (Sloc (Node),
300
        Identifier             => Identifier,
301
        Iteration_Scheme       => Iteration_Scheme,
302
        Statements             => Statements,
303
        Has_Created_Identifier => Has_Created_Identifier,
304
        End_Label              => End_Label);
305
   end Make_Implicit_Loop_Statement;
306
 
307
   --------------------------
308
   -- Make_Integer_Literal --
309
   ---------------------------
310
 
311
   function Make_Integer_Literal
312
     (Loc    : Source_Ptr;
313
      Intval : Int) return Node_Id
314
   is
315
   begin
316
      return Make_Integer_Literal (Loc, UI_From_Int (Intval));
317
   end Make_Integer_Literal;
318
 
319
   --------------------------------
320
   -- Make_Linker_Section_Pragma --
321
   --------------------------------
322
 
323
   function Make_Linker_Section_Pragma
324
     (Ent : Entity_Id;
325
      Loc : Source_Ptr;
326
      Sec : String) return Node_Id
327
   is
328
      LS : Node_Id;
329
 
330
   begin
331
      LS :=
332
        Make_Pragma
333
          (Loc,
334
           Name_Linker_Section,
335
           New_List
336
             (Make_Pragma_Argument_Association
337
                (Sloc => Loc,
338
                 Expression => New_Occurrence_Of (Ent, Loc)),
339
              Make_Pragma_Argument_Association
340
                (Sloc => Loc,
341
                 Expression =>
342
                   Make_String_Literal
343
                     (Sloc => Loc,
344
                      Strval => Sec))));
345
 
346
      Set_Has_Gigi_Rep_Item (Ent);
347
      return LS;
348
   end Make_Linker_Section_Pragma;
349
 
350
   -----------------
351
   -- Make_Pragma --
352
   -----------------
353
 
354
   function Make_Pragma
355
     (Sloc                         : Source_Ptr;
356
      Chars                        : Name_Id;
357
      Pragma_Argument_Associations : List_Id := No_List;
358
      Debug_Statement              : Node_Id := Empty) return Node_Id
359
   is
360
   begin
361
      return
362
        Make_Pragma (Sloc,
363
          Pragma_Argument_Associations => Pragma_Argument_Associations,
364
          Debug_Statement              => Debug_Statement,
365
          Pragma_Identifier            => Make_Identifier (Sloc, Chars));
366
   end Make_Pragma;
367
 
368
   ---------------------------------
369
   -- Make_Raise_Constraint_Error --
370
   ---------------------------------
371
 
372
   function Make_Raise_Constraint_Error
373
     (Sloc      : Source_Ptr;
374
      Condition : Node_Id := Empty;
375
      Reason    : RT_Exception_Code) return Node_Id
376
   is
377
   begin
378
      pragma Assert (Reason in RT_CE_Exceptions);
379
      return
380
        Make_Raise_Constraint_Error (Sloc,
381
          Condition => Condition,
382
          Reason =>
383
            UI_From_Int (RT_Exception_Code'Pos (Reason)));
384
   end Make_Raise_Constraint_Error;
385
 
386
   ------------------------------
387
   -- Make_Raise_Program_Error --
388
   ------------------------------
389
 
390
   function Make_Raise_Program_Error
391
     (Sloc      : Source_Ptr;
392
      Condition : Node_Id := Empty;
393
      Reason    : RT_Exception_Code) return Node_Id
394
   is
395
   begin
396
      pragma Assert (Reason in RT_PE_Exceptions);
397
      return
398
        Make_Raise_Program_Error (Sloc,
399
          Condition => Condition,
400
          Reason =>
401
            UI_From_Int (RT_Exception_Code'Pos (Reason)));
402
   end Make_Raise_Program_Error;
403
 
404
   ------------------------------
405
   -- Make_Raise_Storage_Error --
406
   ------------------------------
407
 
408
   function Make_Raise_Storage_Error
409
     (Sloc      : Source_Ptr;
410
      Condition : Node_Id := Empty;
411
      Reason    : RT_Exception_Code) return Node_Id
412
   is
413
   begin
414
      pragma Assert (Reason in RT_SE_Exceptions);
415
      return
416
        Make_Raise_Storage_Error (Sloc,
417
          Condition => Condition,
418
          Reason =>
419
            UI_From_Int (RT_Exception_Code'Pos (Reason)));
420
   end Make_Raise_Storage_Error;
421
 
422
   -------------------------
423
   -- Make_String_Literal --
424
   -------------------------
425
 
426
   function Make_String_Literal
427
     (Sloc   : Source_Ptr;
428
      Strval : String) return Node_Id
429
   is
430
   begin
431
      Start_String;
432
      Store_String_Chars (Strval);
433
      return
434
        Make_String_Literal (Sloc,
435
          Strval => End_String);
436
   end Make_String_Literal;
437
 
438
   --------------------
439
   -- Make_Temporary --
440
   --------------------
441
 
442
   function Make_Temporary
443
     (Loc          : Source_Ptr;
444
      Id           : Character;
445
      Related_Node : Node_Id := Empty) return Node_Id
446
   is
447
      Temp : constant Node_Id :=
448
               Make_Defining_Identifier (Loc,
449
                 Chars => New_Internal_Name (Id));
450
   begin
451
      Set_Related_Expression (Temp, Related_Node);
452
      return Temp;
453
   end Make_Temporary;
454
 
455
   ---------------------------
456
   -- Make_Unsuppress_Block --
457
   ---------------------------
458
 
459
   --  Generates the following expansion:
460
 
461
   --    declare
462
   --       pragma Suppress (<check>);
463
   --    begin
464
   --       <stmts>
465
   --    end;
466
 
467
   function Make_Unsuppress_Block
468
     (Loc   : Source_Ptr;
469
      Check : Name_Id;
470
      Stmts : List_Id) return Node_Id
471
   is
472
   begin
473
      return
474
        Make_Block_Statement (Loc,
475
          Declarations => New_List (
476
            Make_Pragma (Loc,
477
              Chars => Name_Suppress,
478
              Pragma_Argument_Associations => New_List (
479
                Make_Pragma_Argument_Association (Loc,
480
                  Expression => Make_Identifier (Loc, Check))))),
481
 
482
          Handled_Statement_Sequence =>
483
            Make_Handled_Sequence_Of_Statements (Loc,
484
              Statements => Stmts));
485
   end Make_Unsuppress_Block;
486
 
487
   --------------------------
488
   -- New_Constraint_Error --
489
   --------------------------
490
 
491
   function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
492
      Ident_Node : Node_Id;
493
      Raise_Node : Node_Id;
494
 
495
   begin
496
      Ident_Node := New_Node (N_Identifier, Loc);
497
      Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
498
      Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
499
      Raise_Node := New_Node (N_Raise_Statement, Loc);
500
      Set_Name (Raise_Node, Ident_Node);
501
      return Raise_Node;
502
   end New_Constraint_Error;
503
 
504
   -----------------------
505
   -- New_External_Name --
506
   -----------------------
507
 
508
   function New_External_Name
509
     (Related_Id   : Name_Id;
510
      Suffix       : Character := ' ';
511
      Suffix_Index : Int       := 0;
512
      Prefix       : Character := ' ') return Name_Id
513
   is
514
   begin
515
      Get_Name_String (Related_Id);
516
 
517
      if Prefix /= ' ' then
518
         pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
519
 
520
         for J in reverse 1 .. Name_Len loop
521
            Name_Buffer (J + 1) := Name_Buffer (J);
522
         end loop;
523
 
524
         Name_Len := Name_Len + 1;
525
         Name_Buffer (1) := Prefix;
526
      end if;
527
 
528
      if Suffix /= ' ' then
529
         pragma Assert (Is_OK_Internal_Letter (Suffix));
530
         Add_Char_To_Name_Buffer (Suffix);
531
      end if;
532
 
533
      if Suffix_Index /= 0 then
534
         if Suffix_Index < 0 then
535
            Add_Unique_Serial_Number;
536
         else
537
            Add_Nat_To_Name_Buffer (Suffix_Index);
538
         end if;
539
      end if;
540
 
541
      return Name_Find;
542
   end New_External_Name;
543
 
544
   function New_External_Name
545
     (Related_Id   : Name_Id;
546
      Suffix       : String;
547
      Suffix_Index : Int       := 0;
548
      Prefix       : Character := ' ') return Name_Id
549
   is
550
   begin
551
      Get_Name_String (Related_Id);
552
 
553
      if Prefix /= ' ' then
554
         pragma Assert (Is_OK_Internal_Letter (Prefix));
555
 
556
         for J in reverse 1 .. Name_Len loop
557
            Name_Buffer (J + 1) := Name_Buffer (J);
558
         end loop;
559
 
560
         Name_Len := Name_Len + 1;
561
         Name_Buffer (1) := Prefix;
562
      end if;
563
 
564
      if Suffix /= "" then
565
         Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
566
         Name_Len := Name_Len + Suffix'Length;
567
      end if;
568
 
569
      if Suffix_Index /= 0 then
570
         if Suffix_Index < 0 then
571
            Add_Unique_Serial_Number;
572
         else
573
            Add_Nat_To_Name_Buffer (Suffix_Index);
574
         end if;
575
      end if;
576
 
577
      return Name_Find;
578
   end New_External_Name;
579
 
580
   function New_External_Name
581
     (Suffix       : Character;
582
      Suffix_Index : Nat) return Name_Id
583
   is
584
   begin
585
      Name_Buffer (1) := Suffix;
586
      Name_Len := 1;
587
      Add_Nat_To_Name_Buffer (Suffix_Index);
588
      return Name_Find;
589
   end New_External_Name;
590
 
591
   -----------------------
592
   -- New_Internal_Name --
593
   -----------------------
594
 
595
   function New_Internal_Name (Id_Char : Character) return Name_Id is
596
   begin
597
      pragma Assert (Is_OK_Internal_Letter (Id_Char));
598
      Name_Buffer (1) := Id_Char;
599
      Name_Len := 1;
600
      Add_Unique_Serial_Number;
601
      return Name_Enter;
602
   end New_Internal_Name;
603
 
604
   -----------------------
605
   -- New_Occurrence_Of --
606
   -----------------------
607
 
608
   function New_Occurrence_Of
609
     (Def_Id : Entity_Id;
610
      Loc    : Source_Ptr) return Node_Id
611
   is
612
      Occurrence : Node_Id;
613
 
614
   begin
615
      Occurrence := New_Node (N_Identifier, Loc);
616
      Set_Chars (Occurrence, Chars (Def_Id));
617
      Set_Entity (Occurrence, Def_Id);
618
 
619
      if Is_Type (Def_Id) then
620
         Set_Etype (Occurrence, Def_Id);
621
      else
622
         Set_Etype (Occurrence, Etype (Def_Id));
623
      end if;
624
 
625
      return Occurrence;
626
   end New_Occurrence_Of;
627
 
628
   -----------------
629
   -- New_Op_Node --
630
   -----------------
631
 
632
   function New_Op_Node
633
     (New_Node_Kind : Node_Kind;
634
      New_Sloc      : Source_Ptr) return Node_Id
635
   is
636
      type Name_Of_Type is array (N_Op) of Name_Id;
637
      Name_Of : constant Name_Of_Type := Name_Of_Type'(
638
         N_Op_And                    => Name_Op_And,
639
         N_Op_Or                     => Name_Op_Or,
640
         N_Op_Xor                    => Name_Op_Xor,
641
         N_Op_Eq                     => Name_Op_Eq,
642
         N_Op_Ne                     => Name_Op_Ne,
643
         N_Op_Lt                     => Name_Op_Lt,
644
         N_Op_Le                     => Name_Op_Le,
645
         N_Op_Gt                     => Name_Op_Gt,
646
         N_Op_Ge                     => Name_Op_Ge,
647
         N_Op_Add                    => Name_Op_Add,
648
         N_Op_Subtract               => Name_Op_Subtract,
649
         N_Op_Concat                 => Name_Op_Concat,
650
         N_Op_Multiply               => Name_Op_Multiply,
651
         N_Op_Divide                 => Name_Op_Divide,
652
         N_Op_Mod                    => Name_Op_Mod,
653
         N_Op_Rem                    => Name_Op_Rem,
654
         N_Op_Expon                  => Name_Op_Expon,
655
         N_Op_Plus                   => Name_Op_Add,
656
         N_Op_Minus                  => Name_Op_Subtract,
657
         N_Op_Abs                    => Name_Op_Abs,
658
         N_Op_Not                    => Name_Op_Not,
659
 
660
         --  We don't really need these shift operators, since they never
661
         --  appear as operators in the source, but the path of least
662
         --  resistance is to put them in (the aggregate must be complete)
663
 
664
         N_Op_Rotate_Left            => Name_Rotate_Left,
665
         N_Op_Rotate_Right           => Name_Rotate_Right,
666
         N_Op_Shift_Left             => Name_Shift_Left,
667
         N_Op_Shift_Right            => Name_Shift_Right,
668
         N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
669
 
670
      Nod : constant Node_Id := New_Node (New_Node_Kind, New_Sloc);
671
 
672
   begin
673
      if New_Node_Kind in Name_Of'Range then
674
         Set_Chars (Nod, Name_Of (New_Node_Kind));
675
      end if;
676
 
677
      return Nod;
678
   end New_Op_Node;
679
 
680
   ----------------------
681
   -- New_Reference_To --
682
   ----------------------
683
 
684
   function New_Reference_To
685
     (Def_Id : Entity_Id;
686
      Loc    : Source_Ptr) return Node_Id
687
   is
688
      Occurrence : Node_Id;
689
 
690
   begin
691
      Occurrence := New_Node (N_Identifier, Loc);
692
      Set_Chars (Occurrence, Chars (Def_Id));
693
      Set_Entity (Occurrence, Def_Id);
694
      return Occurrence;
695
   end New_Reference_To;
696
 
697
   -----------------------
698
   -- New_Suffixed_Name --
699
   -----------------------
700
 
701
   function New_Suffixed_Name
702
     (Related_Id : Name_Id;
703
      Suffix     : String) return Name_Id
704
   is
705
   begin
706
      Get_Name_String (Related_Id);
707
      Add_Char_To_Name_Buffer ('_');
708
      Add_Str_To_Name_Buffer (Suffix);
709
      return Name_Find;
710
   end New_Suffixed_Name;
711
 
712
   -------------------
713
   -- OK_Convert_To --
714
   -------------------
715
 
716
   function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
717
      Result : Node_Id;
718
   begin
719
      Result :=
720
        Make_Type_Conversion (Sloc (Expr),
721
          Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
722
          Expression   => Relocate_Node (Expr));
723
      Set_Conversion_OK (Result, True);
724
      Set_Etype (Result, Typ);
725
      return Result;
726
   end OK_Convert_To;
727
 
728
   --------------------------
729
   -- Unchecked_Convert_To --
730
   --------------------------
731
 
732
   function Unchecked_Convert_To
733
     (Typ  : Entity_Id;
734
      Expr : Node_Id) return Node_Id
735
   is
736
      Loc    : constant Source_Ptr := Sloc (Expr);
737
      Result : Node_Id;
738
 
739
   begin
740
      --  If the expression is already of the correct type, then nothing
741
      --  to do, except for relocating the node in case this is required.
742
 
743
      if Present (Etype (Expr))
744
        and then (Base_Type (Etype (Expr)) = Typ
745
                   or else Etype (Expr) = Typ)
746
      then
747
         return Relocate_Node (Expr);
748
 
749
      --  Cases where the inner expression is itself an unchecked conversion
750
      --  to the same type, and we can thus eliminate the outer conversion.
751
 
752
      elsif Nkind (Expr) = N_Unchecked_Type_Conversion
753
        and then Entity (Subtype_Mark (Expr)) = Typ
754
      then
755
         Result := Relocate_Node (Expr);
756
 
757
      elsif Nkind (Expr) = N_Null
758
        and then Is_Access_Type (Typ)
759
      then
760
         --  No need for a conversion
761
 
762
         Result := Relocate_Node (Expr);
763
 
764
      --  All other cases
765
 
766
      else
767
         Result :=
768
           Make_Unchecked_Type_Conversion (Loc,
769
             Subtype_Mark => New_Occurrence_Of (Typ, Loc),
770
             Expression   => Relocate_Node (Expr));
771
      end if;
772
 
773
      Set_Etype (Result, Typ);
774
      return Result;
775
   end Unchecked_Convert_To;
776
 
777
end Tbuild;

powered by: WebSVN 2.1.0

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