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-2012, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Errout; use Errout; 29with Namet; use Namet; 30with Nlists; use Nlists; 31with Sem; use Sem; 32with Sem_Aux; use Sem_Aux; 33with Sem_Util; use Sem_Util; 34with Sinfo; use Sinfo; 35with Snames; use Snames; 36with Stand; use Stand; 37with Targparm; use Targparm; 38 39package 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 pointer 356 -- that is passed by value. In GNAT access parameters are 357 -- treated as IN parameters of an anonymous access type, so 358 -- this falls out free. 359 360 -- The bottom line is that all IN elementary types are 361 -- 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 -- OUT and IN OUT parameters of record types are passed 389 -- by reference regardless of pragmas (RM B.3 (69/2)). 390 391 elsif Ekind_In (Formal, E_Out_Parameter, 392 E_In_Out_Parameter) 393 then 394 Set_Mechanism (Formal, By_Reference); 395 396 -- IN parameters of record types are passed by copy only 397 -- when the related type has convention C_Pass_By_Copy 398 -- (RM B.3 (68.1/2)). 399 400 elsif Ekind (Formal) = E_In_Parameter 401 and then C_Pass_By_Copy (Typ) 402 then 403 Set_Mechanism (Formal, By_Copy); 404 405 -- Otherwise, for a C convention record, we set the 406 -- convention in accordance with a possible use of 407 -- the C_Pass_By_Copy pragma. Note that the value of 408 -- Default_C_Record_Mechanism in the absence of such 409 -- a pragma is By_Reference. 410 411 else 412 Set_Mechanism (Formal, Default_C_Record_Mechanism); 413 end if; 414 415 -- Array types are passed by reference (B.3 (71)) 416 417 elsif Is_Array_Type (Typ) then 418 Set_Mechanism (Formal, By_Reference); 419 420 -- For all other types, use Default_Mechanism mechanism 421 422 else 423 null; 424 end if; 425 426 ----------- 427 -- COBOL -- 428 ----------- 429 430 when Convention_COBOL => 431 432 -- Access parameters (which in GNAT look like IN parameters 433 -- of an access type) are passed by copy (RM B.4(96)) as 434 -- are all other IN parameters of scalar type (RM B.4(97)). 435 436 -- For now we pass these parameters by reference as well. 437 -- The RM specifies the intent BY_CONTENT, but gigi does 438 -- not currently transform By_Copy properly. If we pass by 439 -- reference, it will be imperative to introduce copies ??? 440 441 if Is_Elementary_Type (Typ) 442 and then Ekind (Formal) = E_In_Parameter 443 then 444 Set_Mechanism (Formal, By_Reference); 445 446 -- All other parameters (i.e. all non-scalar types, and 447 -- all OUT or IN OUT parameters) are passed by reference. 448 -- Note that at the moment we are not bothering to make 449 -- copies of scalar types as recommended in the RM. 450 451 else 452 Set_Mechanism (Formal, By_Reference); 453 end if; 454 455 ------------- 456 -- Fortran -- 457 ------------- 458 459 when Convention_Fortran => 460 461 -- In OpenVMS, pass a character of array of character 462 -- value using Descriptor(S). 463 464 if OpenVMS_On_Target 465 and then (Root_Type (Typ) = Standard_Character 466 or else 467 (Is_Array_Type (Typ) 468 and then 469 Root_Type (Component_Type (Typ)) = 470 Standard_Character)) 471 then 472 Set_Mechanism (Formal, By_Descriptor_S); 473 474 -- Access types are passed by default (presumably this 475 -- will mean they are passed by copy) 476 477 elsif Is_Access_Type (Typ) then 478 null; 479 480 -- For now, we pass all other parameters by reference. 481 -- It is not clear that this is right in the long run, 482 -- but it seems to correspond to what gnu f77 wants. 483 484 else 485 Set_Mechanism (Formal, By_Reference); 486 end if; 487 488 end case; 489 end if; 490 491 <<Skip_Formal>> -- remove this when problem above is fixed ??? 492 493 Next_Formal (Formal); 494 end loop; 495 496 -- Note: there is nothing we need to do for the return type here. 497 -- We deal with returning by reference in the Ada sense, by use of 498 -- the flag By_Ref, rather than by messing with mechanisms. 499 500 -- A mechanism of Reference for the return means that an extra 501 -- parameter must be provided for the return value (that is the 502 -- DEC meaning of the pragma), and is unrelated to the Ada notion 503 -- of return by reference. 504 505 -- Note: there was originally code here to set the mechanism to 506 -- By_Reference for types that are "by reference" in the Ada sense, 507 -- but, in accordance with the discussion above, this is wrong, and 508 -- the code was removed. 509 510 end Set_Mechanisms; 511 512end Sem_Mech; 513