OSDN Git Service

2005-06-14 Vincent Celier <celier@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / tbuild.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                               T B U I L D                                --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2005 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 2,  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 COPYING.  If not, write --
19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20 -- MA 02111-1307, USA.                                                      --
21 --                                                                          --
22 -- GNAT was originally developed  by the GNAT team at  New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
24 --                                                                          --
25 ------------------------------------------------------------------------------
26
27 with Atree;    use Atree;
28 with Einfo;    use Einfo;
29 with Elists;   use Elists;
30 with Lib;      use Lib;
31 with Namet;    use Namet;
32 with Nlists;   use Nlists;
33 with Nmake;    use Nmake;
34 with Restrict; use Restrict;
35 with Rident;   use Rident;
36 with Sinfo;    use Sinfo;
37 with Snames;   use Snames;
38 with Stand;    use Stand;
39 with Stringt;  use Stringt;
40 with Uintp;    use Uintp;
41
42 package body Tbuild is
43
44    -----------------------
45    -- Local Subprograms --
46    -----------------------
47
48    procedure Add_Unique_Serial_Number;
49    --  Add a unique serialization to the string in the Name_Buffer. This
50    --  consists of a unit specific serial number, and b/s for body/spec.
51
52    ------------------------------
53    -- Add_Unique_Serial_Number --
54    ------------------------------
55
56    procedure Add_Unique_Serial_Number is
57       Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
58
59    begin
60       Add_Nat_To_Name_Buffer (Increment_Serial_Number);
61
62       --  Add either b or s, depending on whether current unit is a spec
63       --  or a body. This is needed because we may generate the same name
64       --  in a spec and a body otherwise.
65
66       Name_Len := Name_Len + 1;
67
68       if Nkind (Unit_Node) = N_Package_Declaration
69         or else Nkind (Unit_Node) = N_Subprogram_Declaration
70         or else Nkind (Unit_Node) in N_Generic_Declaration
71       then
72          Name_Buffer (Name_Len) := 's';
73       else
74          Name_Buffer (Name_Len) := 'b';
75       end if;
76    end Add_Unique_Serial_Number;
77
78    ----------------
79    -- Checks_Off --
80    ----------------
81
82    function Checks_Off (N : Node_Id) return Node_Id is
83    begin
84       return
85         Make_Unchecked_Expression (Sloc (N),
86           Expression => N);
87    end Checks_Off;
88
89    ----------------
90    -- Convert_To --
91    ----------------
92
93    function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
94       Result : Node_Id;
95
96    begin
97       if Present (Etype (Expr))
98         and then (Etype (Expr)) = Typ
99       then
100          return Relocate_Node (Expr);
101       else
102          Result :=
103            Make_Type_Conversion (Sloc (Expr),
104              Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
105              Expression => Relocate_Node (Expr));
106
107          Set_Etype (Result, Typ);
108          return Result;
109       end if;
110    end Convert_To;
111
112    ------------------
113    -- Discard_List --
114    ------------------
115
116    procedure Discard_List (L : List_Id) is
117       pragma Warnings (Off, L);
118    begin
119       null;
120    end Discard_List;
121
122    ------------------
123    -- Discard_Node --
124    ------------------
125
126    procedure Discard_Node (N : Node_Or_Entity_Id) is
127       pragma Warnings (Off, N);
128    begin
129       null;
130    end Discard_Node;
131
132    -------------------------------------------
133    -- Make_Byte_Aligned_Attribute_Reference --
134    -------------------------------------------
135
136    function Make_Byte_Aligned_Attribute_Reference
137      (Sloc           : Source_Ptr;
138       Prefix         : Node_Id;
139       Attribute_Name : Name_Id)
140       return           Node_Id
141    is
142       N : constant Node_Id :=
143             Make_Attribute_Reference (Sloc,
144               Prefix        => Prefix,
145               Attribute_Name => Attribute_Name);
146
147    begin
148       pragma Assert (Attribute_Name = Name_Address
149                        or else
150                      Attribute_Name = Name_Unrestricted_Access);
151       Set_Must_Be_Byte_Aligned (N, True);
152       return N;
153    end Make_Byte_Aligned_Attribute_Reference;
154
155    --------------------
156    -- Make_DT_Access --
157    --------------------
158
159    function Make_DT_Access
160      (Loc : Source_Ptr;
161       Rec : Node_Id;
162       Typ : Entity_Id) return Node_Id
163    is
164       Full_Type : Entity_Id := Typ;
165
166    begin
167       if Is_Private_Type (Typ) then
168          Full_Type := Underlying_Type (Typ);
169       end if;
170
171       return
172         Unchecked_Convert_To (
173           New_Occurrence_Of
174             (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
175           Make_Selected_Component (Loc,
176             Prefix => New_Copy (Rec),
177             Selector_Name =>
178               New_Reference_To (First_Tag_Component (Full_Type), Loc)));
179    end Make_DT_Access;
180
181    --------------------------------
182    -- Make_Implicit_If_Statement --
183    --------------------------------
184
185    function Make_Implicit_If_Statement
186      (Node            : Node_Id;
187       Condition       : Node_Id;
188       Then_Statements : List_Id;
189       Elsif_Parts     : List_Id := No_List;
190       Else_Statements : List_Id := No_List) return Node_Id
191    is
192    begin
193       Check_Restriction (No_Implicit_Conditionals, Node);
194
195       return Make_If_Statement (Sloc (Node),
196         Condition,
197         Then_Statements,
198         Elsif_Parts,
199         Else_Statements);
200    end Make_Implicit_If_Statement;
201
202    -------------------------------------
203    -- Make_Implicit_Label_Declaration --
204    -------------------------------------
205
206    function Make_Implicit_Label_Declaration
207      (Loc                 : Source_Ptr;
208       Defining_Identifier : Node_Id;
209       Label_Construct     : Node_Id) return Node_Id
210    is
211       N : constant Node_Id :=
212             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
213    begin
214       Set_Label_Construct (N, Label_Construct);
215       return N;
216    end Make_Implicit_Label_Declaration;
217
218    ----------------------------------
219    -- Make_Implicit_Loop_Statement --
220    ----------------------------------
221
222    function Make_Implicit_Loop_Statement
223      (Node                   : Node_Id;
224       Statements             : List_Id;
225       Identifier             : Node_Id := Empty;
226       Iteration_Scheme       : Node_Id := Empty;
227       Has_Created_Identifier : Boolean := False;
228       End_Label              : Node_Id := Empty) return Node_Id
229    is
230    begin
231       Check_Restriction (No_Implicit_Loops, Node);
232
233       if Present (Iteration_Scheme)
234         and then Present (Condition (Iteration_Scheme))
235       then
236          Check_Restriction (No_Implicit_Conditionals, Node);
237       end if;
238
239       return Make_Loop_Statement (Sloc (Node),
240         Identifier             => Identifier,
241         Iteration_Scheme       => Iteration_Scheme,
242         Statements             => Statements,
243         Has_Created_Identifier => Has_Created_Identifier,
244         End_Label              => End_Label);
245    end Make_Implicit_Loop_Statement;
246
247    --------------------------
248    -- Make_Integer_Literal --
249    ---------------------------
250
251    function Make_Integer_Literal
252      (Loc    : Source_Ptr;
253       Intval : Int) return Node_Id
254    is
255    begin
256       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
257    end Make_Integer_Literal;
258
259    ---------------------------------
260    -- Make_Raise_Constraint_Error --
261    ---------------------------------
262
263    function Make_Raise_Constraint_Error
264      (Sloc      : Source_Ptr;
265       Condition : Node_Id := Empty;
266       Reason    : RT_Exception_Code) return Node_Id
267    is
268    begin
269       pragma Assert (Reason in RT_CE_Exceptions);
270       return
271         Make_Raise_Constraint_Error (Sloc,
272           Condition => Condition,
273           Reason =>
274             UI_From_Int (RT_Exception_Code'Pos (Reason)));
275    end Make_Raise_Constraint_Error;
276
277    ------------------------------
278    -- Make_Raise_Program_Error --
279    ------------------------------
280
281    function Make_Raise_Program_Error
282      (Sloc      : Source_Ptr;
283       Condition : Node_Id := Empty;
284       Reason    : RT_Exception_Code) return Node_Id
285    is
286    begin
287       pragma Assert (Reason in RT_PE_Exceptions);
288       return
289         Make_Raise_Program_Error (Sloc,
290           Condition => Condition,
291           Reason =>
292             UI_From_Int (RT_Exception_Code'Pos (Reason)));
293    end Make_Raise_Program_Error;
294
295    ------------------------------
296    -- Make_Raise_Storage_Error --
297    ------------------------------
298
299    function Make_Raise_Storage_Error
300      (Sloc      : Source_Ptr;
301       Condition : Node_Id := Empty;
302       Reason    : RT_Exception_Code) return Node_Id
303    is
304    begin
305       pragma Assert (Reason in RT_SE_Exceptions);
306       return
307         Make_Raise_Storage_Error (Sloc,
308           Condition => Condition,
309           Reason =>
310             UI_From_Int (RT_Exception_Code'Pos (Reason)));
311    end Make_Raise_Storage_Error;
312
313    -------------------------
314    -- Make_String_Literal --
315    -------------------------
316
317    function Make_String_Literal
318      (Sloc   : Source_Ptr;
319       Strval : String) return Node_Id
320    is
321    begin
322       Start_String;
323       Store_String_Chars (Strval);
324       return
325         Make_String_Literal (Sloc,
326           Strval => End_String);
327    end Make_String_Literal;
328
329    ---------------------------
330    -- Make_Unsuppress_Block --
331    ---------------------------
332
333    --  Generates the following expansion:
334
335    --    declare
336    --       pragma Suppress (<check>);
337    --    begin
338    --       <stmts>
339    --    end;
340
341    function Make_Unsuppress_Block
342      (Loc   : Source_Ptr;
343       Check : Name_Id;
344       Stmts : List_Id) return Node_Id
345    is
346    begin
347       return
348         Make_Block_Statement (Loc,
349           Declarations => New_List (
350             Make_Pragma (Loc,
351               Chars => Name_Suppress,
352               Pragma_Argument_Associations => New_List (
353                 Make_Pragma_Argument_Association (Loc,
354                   Expression => Make_Identifier (Loc, Check))))),
355
356           Handled_Statement_Sequence =>
357             Make_Handled_Sequence_Of_Statements (Loc,
358               Statements => Stmts));
359    end Make_Unsuppress_Block;
360
361    --------------------------
362    -- New_Constraint_Error --
363    --------------------------
364
365    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is
366       Ident_Node : Node_Id;
367       Raise_Node : Node_Id;
368
369    begin
370       Ident_Node := New_Node (N_Identifier, Loc);
371       Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error)));
372       Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error));
373       Raise_Node := New_Node (N_Raise_Statement, Loc);
374       Set_Name (Raise_Node, Ident_Node);
375       return Raise_Node;
376    end New_Constraint_Error;
377
378    -----------------------
379    -- New_External_Name --
380    -----------------------
381
382    function New_External_Name
383      (Related_Id   : Name_Id;
384       Suffix       : Character := ' ';
385       Suffix_Index : Int       := 0;
386       Prefix       : Character := ' ') return Name_Id
387    is
388    begin
389       Get_Name_String (Related_Id);
390
391       if Prefix /= ' ' then
392          pragma Assert (Is_OK_Internal_Letter (Prefix));
393
394          for J in reverse 1 .. Name_Len loop
395             Name_Buffer (J + 1) := Name_Buffer (J);
396          end loop;
397
398          Name_Len := Name_Len + 1;
399          Name_Buffer (1) := Prefix;
400       end if;
401
402       if Suffix /= ' ' then
403          pragma Assert (Is_OK_Internal_Letter (Suffix));
404          Name_Len := Name_Len + 1;
405          Name_Buffer (Name_Len) := Suffix;
406       end if;
407
408       if Suffix_Index /= 0 then
409          if Suffix_Index < 0 then
410             Add_Unique_Serial_Number;
411          else
412             Add_Nat_To_Name_Buffer (Suffix_Index);
413          end if;
414       end if;
415
416       return Name_Find;
417    end New_External_Name;
418
419    function New_External_Name
420      (Related_Id   : Name_Id;
421       Suffix       : String;
422       Suffix_Index : Int       := 0;
423       Prefix       : Character := ' ') return Name_Id
424    is
425    begin
426       Get_Name_String (Related_Id);
427
428       if Prefix /= ' ' then
429          pragma Assert (Is_OK_Internal_Letter (Prefix));
430
431          for J in reverse 1 .. Name_Len loop
432             Name_Buffer (J + 1) := Name_Buffer (J);
433          end loop;
434
435          Name_Len := Name_Len + 1;
436          Name_Buffer (1) := Prefix;
437       end if;
438
439       if Suffix /= "" then
440          Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
441          Name_Len := Name_Len + Suffix'Length;
442       end if;
443
444       if Suffix_Index /= 0 then
445          if Suffix_Index < 0 then
446             Add_Unique_Serial_Number;
447          else
448             Add_Nat_To_Name_Buffer (Suffix_Index);
449          end if;
450       end if;
451
452       return Name_Find;
453    end New_External_Name;
454
455    function New_External_Name
456      (Suffix       : Character;
457       Suffix_Index : Nat) return Name_Id
458    is
459    begin
460       Name_Buffer (1) := Suffix;
461       Name_Len := 1;
462       Add_Nat_To_Name_Buffer (Suffix_Index);
463       return Name_Find;
464    end New_External_Name;
465
466    -----------------------
467    -- New_Internal_Name --
468    -----------------------
469
470    function New_Internal_Name (Id_Char : Character) return Name_Id is
471    begin
472       pragma Assert (Is_OK_Internal_Letter (Id_Char));
473       Name_Buffer (1) := Id_Char;
474       Name_Len := 1;
475       Add_Unique_Serial_Number;
476       return Name_Enter;
477    end New_Internal_Name;
478
479    -----------------------
480    -- New_Occurrence_Of --
481    -----------------------
482
483    function New_Occurrence_Of
484      (Def_Id : Entity_Id;
485       Loc    : Source_Ptr) return Node_Id
486    is
487       Occurrence : Node_Id;
488
489    begin
490       Occurrence := New_Node (N_Identifier, Loc);
491       Set_Chars (Occurrence, Chars (Def_Id));
492       Set_Entity (Occurrence, Def_Id);
493
494       if Is_Type (Def_Id) then
495          Set_Etype (Occurrence, Def_Id);
496       else
497          Set_Etype (Occurrence, Etype (Def_Id));
498       end if;
499
500       return Occurrence;
501    end New_Occurrence_Of;
502
503    ----------------------
504    -- New_Reference_To --
505    ----------------------
506
507    function New_Reference_To
508      (Def_Id : Entity_Id;
509       Loc    : Source_Ptr) return Node_Id
510    is
511       Occurrence : Node_Id;
512
513    begin
514       Occurrence := New_Node (N_Identifier, Loc);
515       Set_Chars (Occurrence, Chars (Def_Id));
516       Set_Entity (Occurrence, Def_Id);
517       return Occurrence;
518    end New_Reference_To;
519
520    -----------------------
521    -- New_Suffixed_Name --
522    -----------------------
523
524    function New_Suffixed_Name
525      (Related_Id : Name_Id;
526       Suffix     : String) return Name_Id
527    is
528    begin
529       Get_Name_String (Related_Id);
530       Name_Len := Name_Len + 1;
531       Name_Buffer (Name_Len) := '_';
532       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
533       Name_Len := Name_Len + Suffix'Length;
534       return Name_Find;
535    end New_Suffixed_Name;
536
537    -------------------
538    -- OK_Convert_To --
539    -------------------
540
541    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
542       Result : Node_Id;
543    begin
544       Result :=
545         Make_Type_Conversion (Sloc (Expr),
546           Subtype_Mark => New_Occurrence_Of (Typ, Sloc (Expr)),
547           Expression   => Relocate_Node (Expr));
548       Set_Conversion_OK (Result, True);
549       Set_Etype (Result, Typ);
550       return Result;
551    end OK_Convert_To;
552
553    --------------------------
554    -- Unchecked_Convert_To --
555    --------------------------
556
557    function Unchecked_Convert_To
558      (Typ  : Entity_Id;
559       Expr : Node_Id) return Node_Id
560    is
561       Loc    : constant Source_Ptr := Sloc (Expr);
562       Result : Node_Id;
563
564    begin
565       --  If the expression is already of the correct type, then nothing
566       --  to do, except for relocating the node in case this is required.
567
568       if Present (Etype (Expr))
569         and then (Base_Type (Etype (Expr)) = Typ
570                    or else Etype (Expr) = Typ)
571       then
572          return Relocate_Node (Expr);
573
574       --  Cases where the inner expression is itself an unchecked conversion
575       --  to the same type, and we can thus eliminate the outer conversion.
576
577       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
578         and then Entity (Subtype_Mark (Expr)) = Typ
579       then
580          Result := Relocate_Node (Expr);
581
582       elsif Nkind (Expr) = N_Null
583         and then Is_Access_Type (Typ)
584       then
585          --  No need for a conversion
586
587          Result := Relocate_Node (Expr);
588
589       --  All other cases
590
591       else
592          Result :=
593            Make_Unchecked_Type_Conversion (Loc,
594              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
595              Expression   => Relocate_Node (Expr));
596       end if;
597
598       Set_Etype (Result, Typ);
599       return Result;
600    end Unchecked_Convert_To;
601
602 end Tbuild;