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