summaryrefslogtreecommitdiff
path: root/gcc/ada/sem_mech.adb
blob: 1954b3deb7413db0ebab400c3336a93175d50034 (plain)
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
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ M E C H                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1996-2010, 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 Nlists;   use Nlists;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Stand;    use Stand;
with Targparm; use Targparm;

package body Sem_Mech is

   -------------------------
   -- Set_Mechanism_Value --
   -------------------------

   procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
      Class : Node_Id;
      Param : Node_Id;

      procedure Bad_Class;
      --  Signal bad descriptor class name

      procedure Bad_Mechanism;
      --  Signal bad mechanism name

      procedure Bad_Class is
      begin
         Error_Msg_N ("unrecognized descriptor class name", Class);
      end Bad_Class;

      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 | descriptor | short_descriptor

      if Nkind (Mech_Name) = N_Identifier then
         if Chars (Mech_Name) = Name_Value then
            Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name);
            return;

         elsif Chars (Mech_Name) = Name_Reference then
            Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name);
            return;

         elsif Chars (Mech_Name) = Name_Descriptor then
            Check_VMS (Mech_Name);
            Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
            return;

         elsif Chars (Mech_Name) = Name_Short_Descriptor then
            Check_VMS (Mech_Name);
            Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name);
            return;

         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;
            return;
         end if;

      --  MECHANISM_NAME ::= descriptor (CLASS_NAME) |
      --                     short_descriptor (CLASS_NAME)
      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca

      --  Note: this form is parsed as an indexed component

      elsif Nkind (Mech_Name) = N_Indexed_Component then
         Class := First (Expressions (Mech_Name));

         if Nkind (Prefix (Mech_Name)) /= N_Identifier
           or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
                        Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
           or else Present (Next (Class))
         then
            Bad_Mechanism;
            return;
         end if;

      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
      --                     short_descriptor (Class => CLASS_NAME)
      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca

      --  Note: this form is parsed as a function call

      elsif Nkind (Mech_Name) = N_Function_Call then

         Param := First (Parameter_Associations (Mech_Name));

         if Nkind (Name (Mech_Name)) /= N_Identifier
           or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
                        Chars (Name (Mech_Name)) = Name_Short_Descriptor)
           or else Present (Next (Param))
           or else No (Selector_Name (Param))
           or else Chars (Selector_Name (Param)) /= Name_Class
         then
            Bad_Mechanism;
            return;
         else
            Class := Explicit_Actual_Parameter (Param);
         end if;

      else
         Bad_Mechanism;
         return;
      end if;

      --  Fall through here with Class set to descriptor class name

      Check_VMS (Mech_Name);

      if Nkind (Class) /= N_Identifier then
         Bad_Class;
         return;

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_UBS
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_UBSB
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_UBA
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_S
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_SB
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_A
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Descriptor
        and then Chars (Class) = Name_NCA
      then
         Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_UBS
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS,  Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_UBSB
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_UBA
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA,  Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_S
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S,    Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_SB
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB,   Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_A
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A,    Mech_Name);

      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
        and then Chars (Class) = Name_NCA
      then
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA,  Mech_Name);

      else
         Bad_Class;
         return;
      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
   begin
      --  Right now we only do some checks for functions returning arguments
      --  by descriptor. Probably mode checks need to be added here ???

      if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
         if Is_Record_Type (Etype (Ent)) then
            Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
            return;
         end if;
      end if;

      --  If we fall through, all checks have passed

      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

               when Convention_Ada       |
                    Convention_Intrinsic |
                    Convention_Entry     |
                    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;

               -------
               -- C --
               -------

               --  Note: Assembler, C++, Java, Stdcall also use C conventions

               when Convention_Assembler |
                    Convention_C         |
                    Convention_CIL       |
                    Convention_CPP       |
                    Convention_Java      |
                    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);

                     --  If convention C_Pass_By_Copy was specified for
                     --  the record type, then we pass by copy.

                     elsif 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 =>

                  --  In OpenVMS, pass a character of array of character
                  --  value using Descriptor(S).

                  if OpenVMS_On_Target
                    and then (Root_Type (Typ) = Standard_Character
                               or else
                                 (Is_Array_Type (Typ)
                                   and then
                                     Root_Type (Component_Type (Typ)) =
                                                     Standard_Character))
                  then
                     Set_Mechanism (Formal, By_Descriptor_S);

                  --  Access types are passed by default (presumably this
                  --  will mean they are passed by copy)

                  elsif 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;