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