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