?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
First version committed to git
[zpugcc/jano.git] / toolchain / gcc / gcc / ada / sem_mech.adb
blobcf362241fb6340c8c5dd53f783d38429d3dcd705
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ M E C H --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2003 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 Errout; use Errout;
30 with Targparm; use Targparm;
31 with Nlists; use Nlists;
32 with Sem; use Sem;
33 with Sem_Util; use Sem_Util;
34 with Sinfo; use Sinfo;
35 with Snames; use Snames;
36 with Stand; use Stand;
37
38 package body Sem_Mech is
39
40 -------------------------
41 -- Set_Mechanism_Value --
42 -------------------------
43
44 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
45 Class : Node_Id;
46 Param : Node_Id;
47
48 procedure Bad_Class;
49 -- Signal bad descriptor class name
50
51 procedure Bad_Mechanism;
52 -- Signal bad mechanism name
53
54 procedure Bad_Class is
55 begin
56 Error_Msg_N ("unrecognized descriptor class name", Class);
57 end Bad_Class;
58
59 procedure Bad_Mechanism is
60 begin
61 Error_Msg_N ("unrecognized mechanism name", Mech_Name);
62 end Bad_Mechanism;
63
64 -- Start of processing for Set_Mechanism_Value
65
66 begin
67 if Mechanism (Ent) /= Default_Mechanism then
68 Error_Msg_NE
69 ("mechanism for & has already been set", Mech_Name, Ent);
70 end if;
71
72 -- MECHANISM_NAME ::= value | reference | descriptor
73
74 if Nkind (Mech_Name) = N_Identifier then
75 if Chars (Mech_Name) = Name_Value then
76 Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
77 return;
78
79 elsif Chars (Mech_Name) = Name_Reference then
80 Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
81 return;
82
83 elsif Chars (Mech_Name) = Name_Descriptor then
84 Check_VMS (Mech_Name);
85 Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
86 return;
87
88 elsif Chars (Mech_Name) = Name_Copy then
89 Error_Msg_N
90 ("bad mechanism name, Value assumed", Mech_Name);
91 Set_Mechanism (Ent, By_Copy);
92
93 else
94 Bad_Mechanism;
95 return;
96 end if;
97
98 -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
99 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
100
101 -- Note: this form is parsed as an indexed component
102
103 elsif Nkind (Mech_Name) = N_Indexed_Component then
104 Class := First (Expressions (Mech_Name));
105
106 if Nkind (Prefix (Mech_Name)) /= N_Identifier
107 or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
108 or else Present (Next (Class))
109 then
110 Bad_Mechanism;
111 return;
112 end if;
113
114 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
115 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
116
117 -- Note: this form is parsed as a function call
118
119 elsif Nkind (Mech_Name) = N_Function_Call then
120
121 Param := First (Parameter_Associations (Mech_Name));
122
123 if Nkind (Name (Mech_Name)) /= N_Identifier
124 or else Chars (Name (Mech_Name)) /= Name_Descriptor
125 or else Present (Next (Param))
126 or else No (Selector_Name (Param))
127 or else Chars (Selector_Name (Param)) /= Name_Class
128 then
129 Bad_Mechanism;
130 return;
131 else
132 Class := Explicit_Actual_Parameter (Param);
133 end if;
134
135 else
136 Bad_Mechanism;
137 return;
138 end if;
139
140 -- Fall through here with Class set to descriptor class name
141
142 Check_VMS (Mech_Name);
143
144 if Nkind (Class) /= N_Identifier then
145 Bad_Class;
146 return;
147
148 elsif Chars (Class) = Name_UBS then
149 Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name);
150
151 elsif Chars (Class) = Name_UBSB then
152 Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
153
154 elsif Chars (Class) = Name_UBA then
155 Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name);
156
157 elsif Chars (Class) = Name_S then
158 Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name);
159
160 elsif Chars (Class) = Name_SB then
161 Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name);
162
163 elsif Chars (Class) = Name_A then
164 Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name);
165
166 elsif Chars (Class) = Name_NCA then
167 Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name);
168
169 else
170 Bad_Class;
171 return;
172 end if;
173 end Set_Mechanism_Value;
174
175 -------------------------------
176 -- Set_Mechanism_With_Checks --
177 -------------------------------
178
179 procedure Set_Mechanism_With_Checks
180 (Ent : Entity_Id;
181 Mech : Mechanism_Type;
182 Enod : Node_Id)
183 is
184 begin
185 -- Right now we only do some checks for functions returning arguments
186 -- by desctiptor. Probably mode checks need to be added here ???
187
188 if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
189 if Is_Record_Type (Etype (Ent)) then
190 Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
191 return;
192 end if;
193 end if;
194
195 -- If we fall through, all checks have passed
196
197 Set_Mechanism (Ent, Mech);
198 end Set_Mechanism_With_Checks;
199
200 --------------------
201 -- Set_Mechanisms --
202 --------------------
203
204 procedure Set_Mechanisms (E : Entity_Id) is
205 Formal : Entity_Id;
206 Typ : Entity_Id;
207
208 begin
209 -- Skip this processing if inside a generic template. Not only is
210 -- it uneccessary (since neither extra formals nor mechanisms are
211 -- relevant for the template itself), but at least at the moment,
212 -- procedures get frozen early inside a template so attempting to
213 -- look at the formal types does not work too well if they are
214 -- private types that have not been frozen yet.
215
216 if Inside_A_Generic then
217 return;
218 end if;
219
220 -- Loop through formals
221
222 Formal := First_Formal (E);
223 while Present (Formal) loop
224
225 if Mechanism (Formal) = Default_Mechanism then
226 Typ := Underlying_Type (Etype (Formal));
227
228 -- If there is no underlying type, then skip this processing and
229 -- leave the convention set to Default_Mechanism. It seems odd
230 -- that there should ever be such cases but there are (see
231 -- comments for filed regression tests 1418-001 and 1912-009) ???
232
233 if No (Typ) then
234 goto Skip_Formal;
235 end if;
236
237 case Convention (E) is
238
239 ---------
240 -- Ada --
241 ---------
242
243 -- Note: all RM defined conventions are treated the same
244 -- from the point of view of parameter passing mechanims
245
246 when Convention_Ada |
247 Convention_Intrinsic |
248 Convention_Entry |
249 Convention_Protected |
250 Convention_Stubbed =>
251
252 -- By reference types are passed by reference (RM 6.2(4))
253
254 if Is_By_Reference_Type (Typ) then
255 Set_Mechanism (Formal, By_Reference);
256
257 -- By copy types are passed by copy (RM 6.2(3))
258
259 elsif Is_By_Copy_Type (Typ) then
260 Set_Mechanism (Formal, By_Copy);
261
262 -- All other types we leave the Default_Mechanism set, so
263 -- that the backend can choose the appropriate method.
264
265 else
266 null;
267 end if;
268
269 -------
270 -- C --
271 -------
272
273 -- Note: Assembler, C++, Java, Stdcall also use C conventions
274
275 when Convention_Assembler |
276 Convention_C |
277 Convention_CPP |
278 Convention_Java |
279 Convention_Stdcall =>
280
281 -- The following values are passed by copy
282
283 -- IN Scalar parameters (RM B.3(66))
284 -- IN parameters of access types (RM B.3(67))
285 -- Access parameters (RM B.3(68))
286 -- Access to subprogram types (RM B.3(71))
287
288 -- Note: in the case of access parameters, it is the
289 -- pointer that is passed by value. In GNAT access
290 -- parameters are treated as IN parameters of an
291 -- anonymous access type, so this falls out free.
292
293 -- The bottom line is that all IN elementary types
294 -- are passed by copy in GNAT.
295
296 if Is_Elementary_Type (Typ) then
297 if Ekind (Formal) = E_In_Parameter then
298 Set_Mechanism (Formal, By_Copy);
299
300 -- OUT and IN OUT parameters of elementary types are
301 -- passed by reference (RM B.3(68)). Note that we are
302 -- not following the advice to pass the address of a
303 -- copy to preserve by copy semantics.
304
305 else
306 Set_Mechanism (Formal, By_Reference);
307 end if;
308
309 -- Records are normally passed by reference (RM B.3(69)).
310 -- However, this can be overridden by the use of the
311 -- C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
312
313 elsif Is_Record_Type (Typ) then
314
315 -- If the record is not convention C, then we always
316 -- pass by reference, C_Pass_By_Copy does not apply.
317
318 if Convention (Typ) /= Convention_C then
319 Set_Mechanism (Formal, By_Reference);
320
321 -- If convention C_Pass_By_Copy was specified for
322 -- the record type, then we pass by copy.
323
324 elsif C_Pass_By_Copy (Typ) then
325 Set_Mechanism (Formal, By_Copy);
326
327 -- Otherwise, for a C convention record, we set the
328 -- convention in accordance with a possible use of
329 -- the C_Pass_By_Copy pragma. Note that the value of
330 -- Default_C_Record_Mechanism in the absence of such
331 -- a pragma is By_Reference.
332
333 else
334 Set_Mechanism (Formal, Default_C_Record_Mechanism);
335 end if;
336
337 -- Array types are passed by reference (B.3 (71))
338
339 elsif Is_Array_Type (Typ) then
340 Set_Mechanism (Formal, By_Reference);
341
342 -- For all other types, use Default_Mechanism mechanism
343
344 else
345 null;
346 end if;
347
348 -----------
349 -- COBOL --
350 -----------
351
352 when Convention_COBOL =>
353
354 -- Access parameters (which in GNAT look like IN parameters
355 -- of an access type) are passed by copy (RM B.4(96)) as
356 -- are all other IN parameters of scalar type (RM B.4(97)).
357
358 -- For now we pass these parameters by reference as well.
359 -- The RM specifies the intent BY_CONTENT, but gigi does
360 -- not currently transform By_Copy properly. If we pass by
361 -- reference, it will be imperative to introduce copies ???
362
363 if Is_Elementary_Type (Typ)
364 and then Ekind (Formal) = E_In_Parameter
365 then
366 Set_Mechanism (Formal, By_Reference);
367
368 -- All other parameters (i.e. all non-scalar types, and
369 -- all OUT or IN OUT parameters) are passed by reference.
370 -- Note that at the moment we are not bothering to make
371 -- copies of scalar types as recommended in the RM.
372
373 else
374 Set_Mechanism (Formal, By_Reference);
375 end if;
376
377 -------------
378 -- Fortran --
379 -------------
380
381 when Convention_Fortran =>
382
383 -- In OpenVMS, pass a character of array of character
384 -- value using Descriptor(S).
385
386 if OpenVMS_On_Target
387 and then (Root_Type (Typ) = Standard_Character
388 or else
389 (Is_Array_Type (Typ)
390 and then
391 Root_Type (Component_Type (Typ)) =
392 Standard_Character))
393 then
394 Set_Mechanism (Formal, By_Descriptor_S);
395
396 -- Access types are passed by default (presumably this
397 -- will mean they are passed by copy)
398
399 elsif Is_Access_Type (Typ) then
400 null;
401
402 -- For now, we pass all other parameters by reference.
403 -- It is not clear that this is right in the long run,
404 -- but it seems to correspond to what gnu f77 wants.
405
406 else
407 Set_Mechanism (Formal, By_Reference);
408 end if;
409
410 end case;
411 end if;
412
413 <<Skip_Formal>> -- remove this when problem above is fixed ???
414
415 Next_Formal (Formal);
416 end loop;
417
418 -- Note: there is nothing we need to do for the return type here.
419 -- We deal with returning by reference in the Ada sense, by use of
420 -- the flag By_Ref, rather than by messing with mechanisms.
421
422 -- A mechanism of Reference for the return means that an extra
423 -- parameter must be provided for the return value (that is the
424 -- DEC meaning of the pragma), and is unrelated to the Ada notion
425 -- of return by reference.
426
427 -- Note: there was originally code here to set the mechanism to
428 -- By_Reference for types that are "by reference" in the Ada sense,
429 -- but, in accordance with the discussion above, this is wrong, and
430 -- the code was removed.
431
432 end Set_Mechanisms;
433
434 end Sem_Mech;
my patches to zpugcc