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 --                                                                          --
  10 --          Copyright (C) 1996-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Targparm; use Targparm;
  32 with Nlists;   use Nlists;
  33 with Sem;      use Sem;
  34 with Sem_Util; use Sem_Util;
  35 with Sinfo;    use Sinfo;
  36 with Snames;   use Snames;
  37 with Stand;    use Stand;
  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
  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_Copy then
  90             Error_Msg_N
  91               ("bad mechanism name, Value assumed", Mech_Name);
  92             Set_Mechanism (Ent, By_Copy);
  93
  94          else
  95             Bad_Mechanism;
  96             return;
  97          end if;
  98
  99       --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
 100       --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 101
 102       --  Note: this form is parsed as an indexed component
 103
 104       elsif Nkind (Mech_Name) = N_Indexed_Component then
 105          Class := First (Expressions (Mech_Name));
 106
 107          if Nkind (Prefix (Mech_Name)) /= N_Identifier
 108            or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
 109            or else Present (Next (Class))
 110          then
 111             Bad_Mechanism;
 112             return;
 113          end if;
 114
 115       --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
 116       --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 117
 118       --  Note: this form is parsed as a function call
 119
 120       elsif Nkind (Mech_Name) = N_Function_Call then
 121
 122          Param := First (Parameter_Associations (Mech_Name));
 123
 124          if Nkind (Name (Mech_Name)) /= N_Identifier
 125            or else Chars (Name (Mech_Name)) /= Name_Descriptor
 126            or else Present (Next (Param))
 127            or else No (Selector_Name (Param))
 128            or else Chars (Selector_Name (Param)) /= Name_Class
 129          then
 130             Bad_Mechanism;
 131             return;
 132          else
 133             Class := Explicit_Actual_Parameter (Param);
 134          end if;
 135
 136       else
 137          Bad_Mechanism;
 138          return;
 139       end if;
 140
 141       --  Fall through here with Class set to descriptor class name
 142
 143       Check_VMS (Mech_Name);
 144
 145       if Nkind (Class) /= N_Identifier then
 146          Bad_Class;
 147          return;
 148
 149       elsif Chars (Class) = Name_UBS then
 150          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);
 151
 152       elsif Chars (Class) = Name_UBSB then
 153          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
 154
 155       elsif Chars (Class) = Name_UBA then
 156          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);
 157
 158       elsif Chars (Class) = Name_S then
 159          Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);
 160
 161       elsif Chars (Class) = Name_SB then
 162          Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);
 163
 164       elsif Chars (Class) = Name_A then
 165          Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);
 166
 167       elsif Chars (Class) = Name_NCA then
 168          Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);
 169
 170       else
 171          Bad_Class;
 172          return;
 173       end if;
 174
 175    end Set_Mechanism_Value;
 176
 177    -------------------------------
 178    -- Set_Mechanism_With_Checks --
 179    -------------------------------
 180
 181    procedure Set_Mechanism_With_Checks
 182      (Ent  : Entity_Id;
 183       Mech : Mechanism_Type;
 184       Enod : Node_Id)
 185    is
 186    begin
 187       --  Right now we only do some checks for functions returning arguments
 188       --  by desctiptor. Probably mode checks need to be added here ???
 189
 190       if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
 191          if Is_Record_Type (Etype (Ent)) then
 192             Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
 193             return;
 194          end if;
 195       end if;
 196
 197       --  If we fall through, all checks have passed
 198
 199       Set_Mechanism (Ent, Mech);
 200    end Set_Mechanism_With_Checks;
 201
 202    --------------------
 203    -- Set_Mechanisms --
 204    --------------------
 205
 206    procedure Set_Mechanisms (E : Entity_Id) is
 207       Formal : Entity_Id;
 208       Typ    : Entity_Id;
 209
 210    begin
 211       --  Skip this processing if inside a generic template. Not only is
 212       --  it uneccessary (since neither extra formals nor mechanisms are
 213       --  relevant for the template itself), but at least at the moment,
 214       --  procedures get frozen early inside a template so attempting to
 215       --  look at the formal types does not work too well if they are
 216       --  private types that have not been frozen yet.
 217
 218       if Inside_A_Generic then
 219          return;
 220       end if;
 221
 222       --  Loop through formals
 223
 224       Formal := First_Formal (E);
 225       while Present (Formal) loop
 226
 227          if Mechanism (Formal) = Default_Mechanism then
 228             Typ := Underlying_Type (Etype (Formal));
 229
 230             --  If there is no underlying type, then skip this processing and
 231             --  leave the convention set to Default_Mechanism. It seems odd
 232             --  that there should ever be such cases but there are (see
 233             --  comments for filed regression tests 1418-001 and 1912-009) ???
 234
 235             if No (Typ) then
 236                goto Skip_Formal;
 237             end if;
 238
 239             case Convention (E) is
 240
 241                ---------
 242                -- Ada --
 243                ---------
 244
 245                --  Note: all RM defined conventions are treated the same
 246                --  from the point of view of parameter passing mechanims
 247
 248                when Convention_Ada       |
 249                     Convention_Intrinsic |
 250                     Convention_Entry     |
 251                     Convention_Protected |
 252                     Convention_Stubbed   =>
 253
 254                   --  By reference types are passed by reference (RM 6.2(4))
 255
 256                   if Is_By_Reference_Type (Typ) then
 257                      Set_Mechanism (Formal, By_Reference);
 258
 259                   --  By copy types are passed by copy (RM 6.2(3))
 260
 261                   elsif Is_By_Copy_Type (Typ) then
 262                      Set_Mechanism (Formal, By_Copy);
 263
 264                   --  All other types we leave the Default_Mechanism set, so
 265                   --  that the backend can choose the appropriate method.
 266
 267                   else
 268                      null;
 269                   end if;
 270
 271                -------
 272                -- C --
 273                -------
 274
 275                --  Note: Assembler, C++, Java, Stdcall also use C conventions
 276
 277                when Convention_Assembler |
 278                     Convention_C         |
 279                     Convention_CPP       |
 280                     Convention_Java      |
 281                     Convention_Stdcall   =>
 282
 283                   --  The following values are passed by copy
 284
 285                   --    IN Scalar parameters (RM B.3(66))
 286                   --    IN parameters of access types (RM B.3(67))
 287                   --    Access parameters (RM B.3(68))
 288                   --    Access to subprogram types (RM B.3(71))
 289
 290                   --  Note: in the case of access parameters, it is the
 291                   --  pointer that is passed by value. In GNAT access
 292                   --  parameters are treated as IN parameters of an
 293                   --  anonymous access type, so this falls out free.
 294
 295                   --  The bottom line is that all IN elementary types
 296                   --  are passed by copy in GNAT.
 297
 298                   if Is_Elementary_Type (Typ) then
 299                      if Ekind (Formal) = E_In_Parameter then
 300                         Set_Mechanism (Formal, By_Copy);
 301
 302                      --  OUT and IN OUT parameters of elementary types are
 303                      --  passed by reference (RM B.3(68)). Note that we are
 304                      --  not following the advice to pass the address of a
 305                      --  copy to preserve by copy semantics.
 306
 307                      else
 308                         Set_Mechanism (Formal, By_Reference);
 309                      end if;
 310
 311                   --  Records are normally passed by reference (RM B.3(69)).
 312                   --  However, this can be overridden by the use of the
 313                   --  C_Pass_By_Copy pragma or C_Pass_By_Copy convention.
 314
 315                   elsif Is_Record_Type (Typ) then
 316
 317                      --  If the record is not convention C, then we always
 318                      --  pass by reference, C_Pass_By_Copy does not apply.
 319
 320                      if Convention (Typ) /= Convention_C then
 321                         Set_Mechanism (Formal, By_Reference);
 322
 323                      --  If convention C_Pass_By_Copy was specified for
 324                      --  the record type, then we pass by copy.
 325
 326                      elsif C_Pass_By_Copy (Typ) then
 327                         Set_Mechanism (Formal, By_Copy);
 328
 329                      --  Otherwise, for a C convention record, we set the
 330                      --  convention in accordance with a possible use of
 331                      --  the C_Pass_By_Copy pragma. Note that the value of
 332                      --  Default_C_Record_Mechanism in the absence of such
 333                      --  a pragma is By_Reference.
 334
 335                      else
 336                         Set_Mechanism (Formal, Default_C_Record_Mechanism);
 337                      end if;
 338
 339                   --  Array types are passed by reference (B.3 (71))
 340
 341                   elsif Is_Array_Type (Typ) then
 342                      Set_Mechanism (Formal, By_Reference);
 343
 344                   --  For all other types, use Default_Mechanism mechanism
 345
 346                   else
 347                      null;
 348                   end if;
 349
 350                -----------
 351                -- COBOL --
 352                -----------
 353
 354                when Convention_COBOL =>
 355
 356                   --  Access parameters (which in GNAT look like IN parameters
 357                   --  of an access type) are passed by copy (RM B.4(96)) as
 358                   --  are all other IN parameters of scalar type (RM B.4(97)).
 359
 360                   --  For now we pass these parameters by reference as well.
 361                   --  The RM specifies the intent BY_CONTENT, but gigi does
 362                   --  not currently transform By_Copy properly. If we pass by
 363                   --  reference, it will be imperative to introduce copies ???
 364
 365                   if Is_Elementary_Type (Typ)
 366                     and then Ekind (Formal) = E_In_Parameter
 367                   then
 368                      Set_Mechanism (Formal, By_Reference);
 369
 370                   --  All other parameters (i.e. all non-scalar types, and
 371                   --  all OUT or IN OUT parameters) are passed by reference.
 372                   --  Note that at the moment we are not bothering to make
 373                   --  copies of scalar types as recommended in the RM.
 374
 375                   else
 376                      Set_Mechanism (Formal, By_Reference);
 377                   end if;
 378
 379                -------------
 380                -- Fortran --
 381                -------------
 382
 383                when Convention_Fortran =>
 384
 385                   --  In OpenVMS, pass a character of array of character
 386                   --  value using Descriptor(S).
 387
 388                   if OpenVMS_On_Target
 389                     and then (Root_Type (Typ) = Standard_Character
 390                                or else
 391                                  (Is_Array_Type (Typ)
 392                                    and then
 393                                      Root_Type (Component_Type (Typ)) =
 394                                                      Standard_Character))
 395                   then
 396                      Set_Mechanism (Formal, By_Descriptor_S);
 397
 398                   --  Access types are passed by default (presumably this
 399                   --  will mean they are passed by copy)
 400
 401                   elsif Is_Access_Type (Typ) then
 402                      null;
 403
 404                   --  For now, we pass all other parameters by reference.
 405                   --  It is not clear that this is right in the long run,
 406                   --  but it seems to correspond to what gnu f77 wants.
 407
 408                   else
 409                      Set_Mechanism (Formal, By_Reference);
 410                   end if;
 411
 412             end case;
 413          end if;
 414
 415          <<Skip_Formal>> -- remove this when problem above is fixed ???
 416
 417          Next_Formal (Formal);
 418       end loop;
 419
 420       --  Now deal with return type, we always leave the default mechanism
 421       --  set except for the case of returning a By_Reference type for an
 422       --  Ada convention, where we force return by reference
 423
 424       if Ekind (E) = E_Function
 425         and then Mechanism (E) = Default_Mechanism
 426         and then not Has_Foreign_Convention (E)
 427         and then Is_By_Reference_Type (Etype (E))
 428       then
 429          Set_Mechanism (E, By_Reference);
 430       end if;
 431
 432    end Set_Mechanisms;
 433
 434 end Sem_Mech;