OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_mech.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2011, 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
 
26
with Atree;    use Atree;
27
with Einfo;    use Einfo;
28
with Errout;   use Errout;
29
with Namet;    use Namet;
30
with Nlists;   use Nlists;
31
with Sem;      use Sem;
32
with Sem_Aux;  use Sem_Aux;
33
with Sem_Util; use Sem_Util;
34
with Sinfo;    use Sinfo;
35
with Snames;   use Snames;
36
with Stand;    use Stand;
37
with Targparm; use Targparm;
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 | short_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_Short_Descriptor then
90
            Check_VMS (Mech_Name);
91
            Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name);
92
            return;
93
 
94
         elsif Chars (Mech_Name) = Name_Copy then
95
            Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name);
96
            Set_Mechanism (Ent, By_Copy);
97
 
98
         else
99
            Bad_Mechanism;
100
            return;
101
         end if;
102
 
103
      --  MECHANISM_NAME ::= descriptor (CLASS_NAME) |
104
      --                     short_descriptor (CLASS_NAME)
105
      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
106
 
107
      --  Note: this form is parsed as an indexed component
108
 
109
      elsif Nkind (Mech_Name) = N_Indexed_Component then
110
         Class := First (Expressions (Mech_Name));
111
 
112
         if Nkind (Prefix (Mech_Name)) /= N_Identifier
113
           or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
114
                        Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
115
           or else Present (Next (Class))
116
         then
117
            Bad_Mechanism;
118
            return;
119
         end if;
120
 
121
      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
122
      --                     short_descriptor (Class => CLASS_NAME)
123
      --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
124
 
125
      --  Note: this form is parsed as a function call
126
 
127
      elsif Nkind (Mech_Name) = N_Function_Call then
128
 
129
         Param := First (Parameter_Associations (Mech_Name));
130
 
131
         if Nkind (Name (Mech_Name)) /= N_Identifier
132
           or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
133
                        Chars (Name (Mech_Name)) = Name_Short_Descriptor)
134
           or else Present (Next (Param))
135
           or else No (Selector_Name (Param))
136
           or else Chars (Selector_Name (Param)) /= Name_Class
137
         then
138
            Bad_Mechanism;
139
            return;
140
         else
141
            Class := Explicit_Actual_Parameter (Param);
142
         end if;
143
 
144
      else
145
         Bad_Mechanism;
146
         return;
147
      end if;
148
 
149
      --  Fall through here with Class set to descriptor class name
150
 
151
      Check_VMS (Mech_Name);
152
 
153
      if Nkind (Class) /= N_Identifier then
154
         Bad_Class;
155
         return;
156
 
157
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
158
        and then Chars (Class) = Name_UBS
159
      then
160
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);
161
 
162
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
163
        and then Chars (Class) = Name_UBSB
164
      then
165
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
166
 
167
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
168
        and then Chars (Class) = Name_UBA
169
      then
170
         Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);
171
 
172
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
173
        and then Chars (Class) = Name_S
174
      then
175
         Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);
176
 
177
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
178
        and then Chars (Class) = Name_SB
179
      then
180
         Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);
181
 
182
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
183
        and then Chars (Class) = Name_A
184
      then
185
         Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);
186
 
187
      elsif Chars (Name (Mech_Name)) = Name_Descriptor
188
        and then Chars (Class) = Name_NCA
189
      then
190
         Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);
191
 
192
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
193
        and then Chars (Class) = Name_UBS
194
      then
195
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS,  Mech_Name);
196
 
197
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
198
        and then Chars (Class) = Name_UBSB
199
      then
200
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name);
201
 
202
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
203
        and then Chars (Class) = Name_UBA
204
      then
205
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA,  Mech_Name);
206
 
207
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
208
        and then Chars (Class) = Name_S
209
      then
210
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S,    Mech_Name);
211
 
212
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
213
        and then Chars (Class) = Name_SB
214
      then
215
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB,   Mech_Name);
216
 
217
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
218
        and then Chars (Class) = Name_A
219
      then
220
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A,    Mech_Name);
221
 
222
      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
223
        and then Chars (Class) = Name_NCA
224
      then
225
         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA,  Mech_Name);
226
 
227
      else
228
         Bad_Class;
229
         return;
230
      end if;
231
   end Set_Mechanism_Value;
232
 
233
   -------------------------------
234
   -- Set_Mechanism_With_Checks --
235
   -------------------------------
236
 
237
   procedure Set_Mechanism_With_Checks
238
     (Ent  : Entity_Id;
239
      Mech : Mechanism_Type;
240
      Enod : Node_Id)
241
   is
242
   begin
243
      --  Right now we only do some checks for functions returning arguments
244
      --  by descriptor. Probably mode checks need to be added here ???
245
 
246
      if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
247
         if Is_Record_Type (Etype (Ent)) then
248
            Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
249
            return;
250
         end if;
251
      end if;
252
 
253
      --  If we fall through, all checks have passed
254
 
255
      Set_Mechanism (Ent, Mech);
256
   end Set_Mechanism_With_Checks;
257
 
258
   --------------------
259
   -- Set_Mechanisms --
260
   --------------------
261
 
262
   procedure Set_Mechanisms (E : Entity_Id) is
263
      Formal : Entity_Id;
264
      Typ    : Entity_Id;
265
 
266
   begin
267
      --  Skip this processing if inside a generic template. Not only is
268
      --  it unnecessary (since neither extra formals nor mechanisms are
269
      --  relevant for the template itself), but at least at the moment,
270
      --  procedures get frozen early inside a template so attempting to
271
      --  look at the formal types does not work too well if they are
272
      --  private types that have not been frozen yet.
273
 
274
      if Inside_A_Generic then
275
         return;
276
      end if;
277
 
278
      --  Loop through formals
279
 
280
      Formal := First_Formal (E);
281
      while Present (Formal) loop
282
 
283
         if Mechanism (Formal) = Default_Mechanism then
284
            Typ := Underlying_Type (Etype (Formal));
285
 
286
            --  If there is no underlying type, then skip this processing and
287
            --  leave the convention set to Default_Mechanism. It seems odd
288
            --  that there should ever be such cases but there are (see
289
            --  comments for filed regression tests 1418-001 and 1912-009) ???
290
 
291
            if No (Typ) then
292
               goto Skip_Formal;
293
            end if;
294
 
295
            case Convention (E) is
296
 
297
               ---------
298
               -- Ada --
299
               ---------
300
 
301
               --  Note: all RM defined conventions are treated the same
302
               --  from the point of view of parameter passing mechanism
303
 
304
               when Convention_Ada       |
305
                    Convention_Intrinsic |
306
                    Convention_Entry     |
307
                    Convention_Protected |
308
                    Convention_Stubbed   =>
309
 
310
                  --  By reference types are passed by reference (RM 6.2(4))
311
 
312
                  if Is_By_Reference_Type (Typ) then
313
                     Set_Mechanism (Formal, By_Reference);
314
 
315
                  --  By copy types are passed by copy (RM 6.2(3))
316
 
317
                  elsif Is_By_Copy_Type (Typ) then
318
                     Set_Mechanism (Formal, By_Copy);
319
 
320
                  --  All other types we leave the Default_Mechanism set, so
321
                  --  that the backend can choose the appropriate method.
322
 
323
                  else
324
                     null;
325
                  end if;
326
 
327
               --  Special Ada conventions specifying passing mechanism
328
 
329
               when Convention_Ada_Pass_By_Copy =>
330
                  Set_Mechanism (Formal, By_Copy);
331
 
332
               when Convention_Ada_Pass_By_Reference =>
333
                  Set_Mechanism (Formal, By_Reference);
334
 
335
               -------
336
               -- C --
337
               -------
338
 
339
               --  Note: Assembler, C++, Java, Stdcall also use C conventions
340
 
341
               when Convention_Assembler |
342
                    Convention_C         |
343
                    Convention_CIL       |
344
                    Convention_CPP       |
345
                    Convention_Java      |
346
                    Convention_Stdcall   =>
347
 
348
                  --  The following values are passed by copy
349
 
350
                  --    IN Scalar parameters (RM B.3(66))
351
                  --    IN parameters of access types (RM B.3(67))
352
                  --    Access parameters (RM B.3(68))
353
                  --    Access to subprogram types (RM B.3(71))
354
 
355
                  --  Note: in the case of access parameters, it is the
356
                  --  pointer that is passed by value. In GNAT access
357
                  --  parameters are treated as IN parameters of an
358
                  --  anonymous access type, so this falls out free.
359
 
360
                  --  The bottom line is that all IN elementary types
361
                  --  are passed by copy in GNAT.
362
 
363
                  if Is_Elementary_Type (Typ) then
364
                     if Ekind (Formal) = E_In_Parameter then
365
                        Set_Mechanism (Formal, By_Copy);
366
 
367
                     --  OUT and IN OUT parameters of elementary types are
368
                     --  passed by reference (RM B.3(68)). Note that we are
369
                     --  not following the advice to pass the address of a
370
                     --  copy to preserve by copy semantics.
371
 
372
                     else
373
                        Set_Mechanism (Formal, By_Reference);
374
                     end if;
375
 
376
                  --  Records are normally passed by reference (RM B.3(69)).
377
                  --  However, this can be overridden by the use of the
378
                  --  C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
379
 
380
                  elsif Is_Record_Type (Typ) then
381
 
382
                     --  If the record is not convention C, then we always
383
                     --  pass by reference, C_Pass_By_Copy does not apply.
384
 
385
                     if Convention (Typ) /= Convention_C then
386
                        Set_Mechanism (Formal, By_Reference);
387
 
388
                     --  If convention C_Pass_By_Copy was specified for
389
                     --  the record type, then we pass by copy.
390
 
391
                     elsif C_Pass_By_Copy (Typ) then
392
                        Set_Mechanism (Formal, By_Copy);
393
 
394
                     --  Otherwise, for a C convention record, we set the
395
                     --  convention in accordance with a possible use of
396
                     --  the C_Pass_By_Copy pragma. Note that the value of
397
                     --  Default_C_Record_Mechanism in the absence of such
398
                     --  a pragma is By_Reference.
399
 
400
                     else
401
                        Set_Mechanism (Formal, Default_C_Record_Mechanism);
402
                     end if;
403
 
404
                  --  Array types are passed by reference (B.3 (71))
405
 
406
                  elsif Is_Array_Type (Typ) then
407
                     Set_Mechanism (Formal, By_Reference);
408
 
409
                  --  For all other types, use Default_Mechanism mechanism
410
 
411
                  else
412
                     null;
413
                  end if;
414
 
415
               -----------
416
               -- COBOL --
417
               -----------
418
 
419
               when Convention_COBOL =>
420
 
421
                  --  Access parameters (which in GNAT look like IN parameters
422
                  --  of an access type) are passed by copy (RM B.4(96)) as
423
                  --  are all other IN parameters of scalar type (RM B.4(97)).
424
 
425
                  --  For now we pass these parameters by reference as well.
426
                  --  The RM specifies the intent BY_CONTENT, but gigi does
427
                  --  not currently transform By_Copy properly. If we pass by
428
                  --  reference, it will be imperative to introduce copies ???
429
 
430
                  if Is_Elementary_Type (Typ)
431
                    and then Ekind (Formal) = E_In_Parameter
432
                  then
433
                     Set_Mechanism (Formal, By_Reference);
434
 
435
                  --  All other parameters (i.e. all non-scalar types, and
436
                  --  all OUT or IN OUT parameters) are passed by reference.
437
                  --  Note that at the moment we are not bothering to make
438
                  --  copies of scalar types as recommended in the RM.
439
 
440
                  else
441
                     Set_Mechanism (Formal, By_Reference);
442
                  end if;
443
 
444
               -------------
445
               -- Fortran --
446
               -------------
447
 
448
               when Convention_Fortran =>
449
 
450
                  --  In OpenVMS, pass a character of array of character
451
                  --  value using Descriptor(S).
452
 
453
                  if OpenVMS_On_Target
454
                    and then (Root_Type (Typ) = Standard_Character
455
                               or else
456
                                 (Is_Array_Type (Typ)
457
                                   and then
458
                                     Root_Type (Component_Type (Typ)) =
459
                                                     Standard_Character))
460
                  then
461
                     Set_Mechanism (Formal, By_Descriptor_S);
462
 
463
                  --  Access types are passed by default (presumably this
464
                  --  will mean they are passed by copy)
465
 
466
                  elsif Is_Access_Type (Typ) then
467
                     null;
468
 
469
                  --  For now, we pass all other parameters by reference.
470
                  --  It is not clear that this is right in the long run,
471
                  --  but it seems to correspond to what gnu f77 wants.
472
 
473
                  else
474
                     Set_Mechanism (Formal, By_Reference);
475
                  end if;
476
 
477
            end case;
478
         end if;
479
 
480
         <<Skip_Formal>> -- remove this when problem above is fixed ???
481
 
482
         Next_Formal (Formal);
483
      end loop;
484
 
485
      --  Note: there is nothing we need to do for the return type here.
486
      --  We deal with returning by reference in the Ada sense, by use of
487
      --  the flag By_Ref, rather than by messing with mechanisms.
488
 
489
      --  A mechanism of Reference for the return means that an extra
490
      --  parameter must be provided for the return value (that is the
491
      --  DEC meaning of the pragma), and is unrelated to the Ada notion
492
      --  of return by reference.
493
 
494
      --  Note: there was originally code here to set the mechanism to
495
      --  By_Reference for types that are "by reference" in the Ada sense,
496
      --  but, in accordance with the discussion above, this is wrong, and
497
      --  the code was removed.
498
 
499
   end Set_Mechanisms;
500
 
501
end Sem_Mech;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.