1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ M E C H --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2016, 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 Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Snames; use Snames;
package body Sem_Mech is
-------------------------
-- Set_Mechanism_Value --
-------------------------
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
procedure Bad_Mechanism;
-- Signal bad mechanism name
-------------------
-- Bad_Mechanism --
-------------------
procedure Bad_Mechanism is
begin
Error_Msg_N ("unrecognized mechanism name", Mech_Name);
end Bad_Mechanism;
-- Start of processing for Set_Mechanism_Value
begin
if Mechanism (Ent) /= Default_Mechanism then
Error_Msg_NE
("mechanism for & has already been set", Mech_Name, Ent);
end if;
-- MECHANISM_NAME ::= value | reference
if Nkind (Mech_Name) = N_Identifier then
if Chars (Mech_Name) = Name_Value then
Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
elsif Chars (Mech_Name) = Name_Reference then
Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
elsif Chars (Mech_Name) = Name_Copy then
Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name);
Set_Mechanism (Ent, By_Copy);
else
Bad_Mechanism;
end if;
else
Bad_Mechanism;
end if;
end Set_Mechanism_Value;
-------------------------------
-- Set_Mechanism_With_Checks --
-------------------------------
procedure Set_Mechanism_With_Checks
(Ent : Entity_Id;
Mech : Mechanism_Type;
Enod : Node_Id)
is
pragma Unreferenced (Enod);
begin
-- Right now we don't do any checks, should we do more ???
Set_Mechanism (Ent, Mech);
end Set_Mechanism_With_Checks;
--------------------
-- Set_Mechanisms --
--------------------
procedure Set_Mechanisms (E : Entity_Id) is
Formal : Entity_Id;
Typ : Entity_Id;
begin
-- Skip this processing if inside a generic template. Not only is
-- it unnecessary (since neither extra formals nor mechanisms are
-- relevant for the template itself), but at least at the moment,
-- procedures get frozen early inside a template so attempting to
-- look at the formal types does not work too well if they are
-- private types that have not been frozen yet.
if Inside_A_Generic then
return;
end if;
-- Loop through formals
Formal := First_Formal (E);
while Present (Formal) loop
if Mechanism (Formal) = Default_Mechanism then
Typ := Underlying_Type (Etype (Formal));
-- If there is no underlying type, then skip this processing and
-- leave the convention set to Default_Mechanism. It seems odd
-- that there should ever be such cases but there are (see
-- comments for filed regression tests 1418-001 and 1912-009) ???
if No (Typ) then
goto Skip_Formal;
end if;
case Convention (E) is
---------
-- Ada --
---------
-- Note: all RM defined conventions are treated the same from
-- the point of view of parameter passing mechanism. Convention
-- Ghost has the same dynamic semantics as convention Ada.
when Convention_Ada
| Convention_Entry
| Convention_Intrinsic
| Convention_Protected
| Convention_Stubbed
=>
-- By reference types are passed by reference (RM 6.2(4))
if Is_By_Reference_Type (Typ) then
Set_Mechanism (Formal, By_Reference);
-- By copy types are passed by copy (RM 6.2(3))
elsif Is_By_Copy_Type (Typ) then
Set_Mechanism (Formal, By_Copy);
-- All other types we leave the Default_Mechanism set, so
-- that the backend can choose the appropriate method.
else
null;
end if;
-- Special Ada conventions specifying passing mechanism
when Convention_Ada_Pass_By_Copy =>
Set_Mechanism (Formal, By_Copy);
when Convention_Ada_Pass_By_Reference =>
Set_Mechanism (Formal, By_Reference);
-------
-- C --
-------
-- Note: Assembler, C++, Stdcall also use C conventions
when Convention_Assembler
| Convention_C
| Convention_CPP
| Convention_Stdcall
=>
-- The following values are passed by copy
-- IN Scalar parameters (RM B.3(66))
-- IN parameters of access types (RM B.3(67))
-- Access parameters (RM B.3(68))
-- Access to subprogram types (RM B.3(71))
-- Note: in the case of access parameters, it is the pointer
-- that is passed by value. In GNAT access parameters are
-- treated as IN parameters of an anonymous access type, so
-- this falls out free.
-- The bottom line is that all IN elementary types are
-- passed by copy in GNAT.
if Is_Elementary_Type (Typ) then
if Ekind (Formal) = E_In_Parameter then
Set_Mechanism (Formal, By_Copy);
-- OUT and IN OUT parameters of elementary types are
-- passed by reference (RM B.3(68)). Note that we are
-- not following the advice to pass the address of a
-- copy to preserve by copy semantics.
else
Set_Mechanism (Formal, By_Reference);
end if;
-- Records are normally passed by reference (RM B.3(69)).
-- However, this can be overridden by the use of the
-- C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
elsif Is_Record_Type (Typ) then
-- If the record is not convention C, then we always
-- pass by reference, C_Pass_By_Copy does not apply.
if Convention (Typ) /= Convention_C then
Set_Mechanism (Formal, By_Reference);
-- OUT and IN OUT parameters of record types are passed
-- by reference regardless of pragmas (RM B.3 (69/2)).
elsif Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
then
Set_Mechanism (Formal, By_Reference);
-- IN parameters of record types are passed by copy only
-- when the related type has convention C_Pass_By_Copy
-- (RM B.3 (68.1/2)).
elsif Ekind (Formal) = E_In_Parameter
and then C_Pass_By_Copy (Typ)
then
Set_Mechanism (Formal, By_Copy);
-- Otherwise, for a C convention record, we set the
-- convention in accordance with a possible use of
-- the C_Pass_By_Copy pragma. Note that the value of
-- Default_C_Record_Mechanism in the absence of such
-- a pragma is By_Reference.
else
Set_Mechanism (Formal, Default_C_Record_Mechanism);
end if;
-- Array types are passed by reference (B.3 (71))
elsif Is_Array_Type (Typ) then
Set_Mechanism (Formal, By_Reference);
-- For all other types, use Default_Mechanism mechanism
else
null;
end if;
-----------
-- COBOL --
-----------
when Convention_COBOL =>
-- Access parameters (which in GNAT look like IN parameters
-- of an access type) are passed by copy (RM B.4(96)) as
-- are all other IN parameters of scalar type (RM B.4(97)).
-- For now we pass these parameters by reference as well.
-- The RM specifies the intent BY_CONTENT, but gigi does
-- not currently transform By_Copy properly. If we pass by
-- reference, it will be imperative to introduce copies ???
if Is_Elementary_Type (Typ)
and then Ekind (Formal) = E_In_Parameter
then
Set_Mechanism (Formal, By_Reference);
-- All other parameters (i.e. all non-scalar types, and
-- all OUT or IN OUT parameters) are passed by reference.
-- Note that at the moment we are not bothering to make
-- copies of scalar types as recommended in the RM.
else
Set_Mechanism (Formal, By_Reference);
end if;
-------------
-- Fortran --
-------------
when Convention_Fortran =>
-- Access types are passed by default (presumably this
-- will mean they are passed by copy)
if Is_Access_Type (Typ) then
null;
-- For now, we pass all other parameters by reference.
-- It is not clear that this is right in the long run,
-- but it seems to correspond to what gnu f77 wants.
else
Set_Mechanism (Formal, By_Reference);
end if;
end case;
end if;
<<Skip_Formal>> -- remove this when problem above is fixed ???
Next_Formal (Formal);
end loop;
-- Note: there is nothing we need to do for the return type here.
-- We deal with returning by reference in the Ada sense, by use of
-- the flag By_Ref, rather than by messing with mechanisms.
-- A mechanism of Reference for the return means that an extra
-- parameter must be provided for the return value (that is the
-- DEC meaning of the pragma), and is unrelated to the Ada notion
-- of return by reference.
-- Note: there was originally code here to set the mechanism to
-- By_Reference for types that are "by reference" in the Ada sense,
-- but, in accordance with the discussion above, this is wrong, and
-- the code was removed.
end Set_Mechanisms;
end Sem_Mech;
|
