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 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 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 character and string types using 466 -- Short_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_Short_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 515end Sem_Mech; 516