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

Subversion Repositories openrisc

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

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


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E X P _ S E L                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Einfo;   use Einfo;
with Nlists;  use Nlists;
with Nmake;   use Nmake;
with Opt;     use Opt;
with Rtsfind; use Rtsfind;
with Sinfo;   use Sinfo;
with Snames;  use Snames;
with Stand;   use Stand;
with Tbuild;  use Tbuild;
 
package body Exp_Sel is
 
   -----------------------
   -- Build_Abort_Block --
   -----------------------
 
   function Build_Abort_Block
     (Loc         : Source_Ptr;
      Abr_Blk_Ent : Entity_Id;
      Cln_Blk_Ent : Entity_Id;
      Blk         : Node_Id) return Node_Id
   is
   begin
      return
        Make_Block_Statement (Loc,
          Identifier   => New_Reference_To (Abr_Blk_Ent, Loc),
 
          Declarations => No_List,
 
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements =>
                New_List (
                  Make_Implicit_Label_Declaration (Loc,
                    Defining_Identifier => Cln_Blk_Ent,
                    Label_Construct     => Blk),
                  Blk),
 
              Exception_Handlers =>
                New_List (Build_Abort_Block_Handler (Loc))));
   end Build_Abort_Block;
 
   -------------------------------
   -- Build_Abort_Block_Handler --
   -------------------------------
 
   function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is
      Stmt : Node_Id;
 
   begin
      if Exception_Mechanism = Back_End_Exceptions then
 
         --  With ZCX, aborts are not defered in handlers
 
         Stmt := Make_Null_Statement (Loc);
      else
         --  With FE SJLJ, aborts are defered at the beginning of Abort_Signal
         --  handlers.
 
         Stmt :=
           Make_Procedure_Call_Statement (Loc,
             Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
             Parameter_Associations => No_List);
      end if;
 
      return Make_Implicit_Exception_Handler (Loc,
        Exception_Choices =>
          New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
        Statements        => New_List (Stmt));
   end Build_Abort_Block_Handler;
 
   -------------
   -- Build_B --
   -------------
 
   function Build_B
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      B : constant Entity_Id := Make_Temporary (Loc, 'B');
   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => B,
          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
          Expression          => New_Reference_To (Standard_False, Loc)));
      return B;
   end Build_B;
 
   -------------
   -- Build_C --
   -------------
 
   function Build_C
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      C : constant Entity_Id := Make_Temporary (Loc, 'C');
   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => C,
          Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
      return C;
   end Build_C;
 
   -------------------------
   -- Build_Cleanup_Block --
   -------------------------
 
   function Build_Cleanup_Block
     (Loc       : Source_Ptr;
      Blk_Ent   : Entity_Id;
      Stmts     : List_Id;
      Clean_Ent : Entity_Id) return Node_Id
   is
      Cleanup_Block : constant Node_Id :=
                        Make_Block_Statement (Loc,
                          Identifier                 =>
                            New_Reference_To (Blk_Ent, Loc),
                          Declarations               => No_List,
                          Handled_Statement_Sequence =>
                            Make_Handled_Sequence_Of_Statements (Loc,
                              Statements => Stmts),
                          Is_Asynchronous_Call_Block => True);
 
   begin
      Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
 
      return Cleanup_Block;
   end Build_Cleanup_Block;
 
   -------------
   -- Build_K --
   -------------
 
   function Build_K
     (Loc   : Source_Ptr;
      Decls : List_Id;
      Obj   : Entity_Id) return Entity_Id
   is
      K        : constant Entity_Id := Make_Temporary (Loc, 'K');
      Tag_Node : Node_Id;
 
   begin
      if Tagged_Type_Expansion then
         Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);
      else
         Tag_Node :=
           Make_Attribute_Reference (Loc,
             Prefix         => Obj,
             Attribute_Name => Name_Tag);
      end if;
 
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => K,
          Object_Definition   =>
            New_Reference_To (RTE (RE_Tagged_Kind), Loc),
          Expression          =>
            Make_Function_Call (Loc,
              Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
              Parameter_Associations => New_List (Tag_Node))));
      return K;
   end Build_K;
 
   -------------
   -- Build_S --
   -------------
 
   function Build_S
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      S : constant Entity_Id := Make_Temporary (Loc, 'S');
   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => S,
          Object_Definition   => New_Reference_To (Standard_Integer, Loc)));
      return S;
   end Build_S;
 
   ------------------------
   -- Build_S_Assignment --
   ------------------------
 
   function Build_S_Assignment
     (Loc      : Source_Ptr;
      S        : Entity_Id;
      Obj      : Entity_Id;
      Call_Ent : Entity_Id) return Node_Id
   is
      Typ : constant Entity_Id := Etype (Obj);
 
   begin
      if Tagged_Type_Expansion then
         return
           Make_Assignment_Statement (Loc,
             Name       => New_Reference_To (S, Loc),
             Expression =>
               Make_Function_Call (Loc,
                 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
                 Parameter_Associations => New_List (
                   Unchecked_Convert_To (RTE (RE_Tag), Obj),
                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
 
      --  VM targets
 
      else
         return
           Make_Assignment_Statement (Loc,
             Name       => New_Reference_To (S, Loc),
             Expression =>
               Make_Function_Call (Loc,
                 Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
 
                 Parameter_Associations => New_List (
 
                     --  Obj_Typ
 
                   Make_Attribute_Reference (Loc,
                     Prefix => Obj,
                     Attribute_Name => Name_Tag),
 
                     --  Iface_Typ
 
                   Make_Attribute_Reference (Loc,
                     Prefix => New_Reference_To (Typ, Loc),
                     Attribute_Name => Name_Tag),
 
                     --  Position
 
                   Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
      end if;
   end Build_S_Assignment;
 
end Exp_Sel;

Browse

Tools

Subversion Repositories openrisc

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

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- E X P _ S E L --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Einfo; use Einfo;`
27			`with Nlists; use Nlists;`
28			`with Nmake; use Nmake;`
29			`with Opt; use Opt;`
30			`with Rtsfind; use Rtsfind;`
31			`with Sinfo; use Sinfo;`
32			`with Snames; use Snames;`
33			`with Stand; use Stand;`
34			`with Tbuild; use Tbuild;`
35
36			`package body Exp_Sel is`
37
38			`-----------------------`
39			`-- Build_Abort_Block --`
40			`-----------------------`
41
42			`function Build_Abort_Block`
43			`(Loc : Source_Ptr;`
44			`Abr_Blk_Ent : Entity_Id;`
45			`Cln_Blk_Ent : Entity_Id;`
46			`Blk : Node_Id) return Node_Id`
47			`is`
48			`begin`
49			`return`
50			`Make_Block_Statement (Loc,`
51			`Identifier => New_Reference_To (Abr_Blk_Ent, Loc),`
52
53			`Declarations => No_List,`
54
55			`Handled_Statement_Sequence =>`
56			`Make_Handled_Sequence_Of_Statements (Loc,`
57			`Statements =>`
58			`New_List (`
59			`Make_Implicit_Label_Declaration (Loc,`
60			`Defining_Identifier => Cln_Blk_Ent,`
61			`Label_Construct => Blk),`
62			`Blk),`
63
64			`Exception_Handlers =>`
65			`New_List (Build_Abort_Block_Handler (Loc))));`
66			`end Build_Abort_Block;`
67
68			`-------------------------------`
69			`-- Build_Abort_Block_Handler --`
70			`-------------------------------`
71
72			`function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id is`
73			`Stmt : Node_Id;`
74
75			`begin`
76			`if Exception_Mechanism = Back_End_Exceptions then`
77
78			`-- With ZCX, aborts are not defered in handlers`
79
80			`Stmt := Make_Null_Statement (Loc);`
81			`else`
82			`-- With FE SJLJ, aborts are defered at the beginning of Abort_Signal`
83			`-- handlers.`
84
85			`Stmt :=`
86			`Make_Procedure_Call_Statement (Loc,`
87			`Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),`
88			`Parameter_Associations => No_List);`
89			`end if;`
90
91			`return Make_Implicit_Exception_Handler (Loc,`
92			`Exception_Choices =>`
93			`New_List (New_Reference_To (Stand.Abort_Signal, Loc)),`
94			`Statements => New_List (Stmt));`
95			`end Build_Abort_Block_Handler;`
96
97			`-------------`
98			`-- Build_B --`
99			`-------------`
100
101			`function Build_B`
102			`(Loc : Source_Ptr;`
103			`Decls : List_Id) return Entity_Id`
104			`is`
105			`B : constant Entity_Id := Make_Temporary (Loc, 'B');`
106			`begin`
107			`Append_To (Decls,`
108			`Make_Object_Declaration (Loc,`
109			`Defining_Identifier => B,`
110			`Object_Definition => New_Reference_To (Standard_Boolean, Loc),`
111			`Expression => New_Reference_To (Standard_False, Loc)));`
112			`return B;`
113			`end Build_B;`
114
115			`-------------`
116			`-- Build_C --`
117			`-------------`
118
119			`function Build_C`
120			`(Loc : Source_Ptr;`
121			`Decls : List_Id) return Entity_Id`
122			`is`
123			`C : constant Entity_Id := Make_Temporary (Loc, 'C');`
124			`begin`
125			`Append_To (Decls,`
126			`Make_Object_Declaration (Loc,`
127			`Defining_Identifier => C,`
128			`Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));`
129			`return C;`
130			`end Build_C;`
131
132			`-------------------------`
133			`-- Build_Cleanup_Block --`
134			`-------------------------`
135
136			`function Build_Cleanup_Block`
137			`(Loc : Source_Ptr;`
138			`Blk_Ent : Entity_Id;`
139			`Stmts : List_Id;`
140			`Clean_Ent : Entity_Id) return Node_Id`
141			`is`
142			`Cleanup_Block : constant Node_Id :=`
143			`Make_Block_Statement (Loc,`
144			`Identifier =>`
145			`New_Reference_To (Blk_Ent, Loc),`
146			`Declarations => No_List,`
147			`Handled_Statement_Sequence =>`
148			`Make_Handled_Sequence_Of_Statements (Loc,`
149			`Statements => Stmts),`
150			`Is_Asynchronous_Call_Block => True);`
151
152			`begin`
153			`Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);`
154
155			`return Cleanup_Block;`
156			`end Build_Cleanup_Block;`
157
158			`-------------`
159			`-- Build_K --`
160			`-------------`
161
162			`function Build_K`
163			`(Loc : Source_Ptr;`
164			`Decls : List_Id;`
165			`Obj : Entity_Id) return Entity_Id`
166			`is`
167			`K : constant Entity_Id := Make_Temporary (Loc, 'K');`
168			`Tag_Node : Node_Id;`
169
170			`begin`
171			`if Tagged_Type_Expansion then`
172			`Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), Obj);`
173			`else`
174			`Tag_Node :=`
175			`Make_Attribute_Reference (Loc,`
176			`Prefix => Obj,`
177			`Attribute_Name => Name_Tag);`
178			`end if;`
179
180			`Append_To (Decls,`
181			`Make_Object_Declaration (Loc,`
182			`Defining_Identifier => K,`
183			`Object_Definition =>`
184			`New_Reference_To (RTE (RE_Tagged_Kind), Loc),`
185			`Expression =>`
186			`Make_Function_Call (Loc,`
187			`Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),`
188			`Parameter_Associations => New_List (Tag_Node))));`
189			`return K;`
190			`end Build_K;`
191
192			`-------------`
193			`-- Build_S --`
194			`-------------`
195
196			`function Build_S`
197			`(Loc : Source_Ptr;`
198			`Decls : List_Id) return Entity_Id`
199			`is`
200			`S : constant Entity_Id := Make_Temporary (Loc, 'S');`
201			`begin`
202			`Append_To (Decls,`
203			`Make_Object_Declaration (Loc,`
204			`Defining_Identifier => S,`
205			`Object_Definition => New_Reference_To (Standard_Integer, Loc)));`
206			`return S;`
207			`end Build_S;`
208
209			`------------------------`
210			`-- Build_S_Assignment --`
211			`------------------------`
212
213			`function Build_S_Assignment`
214			`(Loc : Source_Ptr;`
215			`S : Entity_Id;`
216			`Obj : Entity_Id;`
217			`Call_Ent : Entity_Id) return Node_Id`
218			`is`
219			`Typ : constant Entity_Id := Etype (Obj);`
220
221			`begin`
222			`if Tagged_Type_Expansion then`
223			`return`
224			`Make_Assignment_Statement (Loc,`
225			`Name => New_Reference_To (S, Loc),`
226			`Expression =>`
227			`Make_Function_Call (Loc,`
228			`Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),`
229			`Parameter_Associations => New_List (`
230			`Unchecked_Convert_To (RTE (RE_Tag), Obj),`
231			`Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));`
232
233			`-- VM targets`
234
235			`else`
236			`return`
237			`Make_Assignment_Statement (Loc,`
238			`Name => New_Reference_To (S, Loc),`
239			`Expression =>`
240			`Make_Function_Call (Loc,`
241			`Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),`
242
243			`Parameter_Associations => New_List (`
244
245			`-- Obj_Typ`
246
247			`Make_Attribute_Reference (Loc,`
248			`Prefix => Obj,`
249			`Attribute_Name => Name_Tag),`
250
251			`-- Iface_Typ`
252
253			`Make_Attribute_Reference (Loc,`
254			`Prefix => New_Reference_To (Typ, Loc),`
255			`Attribute_Name => Name_Tag),`
256
257			`-- Position`
258
259			`Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));`
260			`end if;`
261			`end Build_S_Assignment;`
262
263			`end Exp_Sel;`