gcc/ada/sem_mech.adb

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