1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ I N T R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 26-- Processing for intrinsic subprogram declarations 27 28with Atree; use Atree; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Fname; use Fname; 32with Lib; use Lib; 33with Namet; use Namet; 34with Sem_Aux; use Sem_Aux; 35with Sem_Eval; use Sem_Eval; 36with Sem_Util; use Sem_Util; 37with Sinfo; use Sinfo; 38with Snames; use Snames; 39with Stand; use Stand; 40with Stringt; use Stringt; 41with Targparm; use Targparm; 42with Uintp; use Uintp; 43 44package body Sem_Intr is 45 46 ----------------------- 47 -- Local Subprograms -- 48 ----------------------- 49 50 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id); 51 -- Check use of intrinsic Exception_Message, Exception_Info or 52 -- Exception_Name, as used in the DEC compatible Current_Exceptions 53 -- package. In each case we must have a parameterless function that 54 -- returns type String. 55 56 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); 57 -- Check that operator is one of the binary arithmetic operators, and that 58 -- the types involved both have underlying integer types. 59 60 procedure Check_Shift (E : Entity_Id; N : Node_Id); 61 -- Check intrinsic shift subprogram, the two arguments are the same 62 -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram 63 -- declaration, and the node for the pragma argument, used for messages) 64 65 procedure Errint (Msg : String; S : Node_Id; N : Node_Id); 66 -- Post error message for bad intrinsic, the message itself is posted 67 -- on the appropriate spec node and another message is placed on the 68 -- pragma itself, referring to the spec. S is the node in the spec on 69 -- which the message is to be placed, and N is the pragma argument node. 70 71 ------------------------------ 72 -- Check_Exception_Function -- 73 ------------------------------ 74 75 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is 76 begin 77 if not Ekind_In (E, E_Function, E_Generic_Function) then 78 Errint 79 ("intrinsic exception subprogram must be a function", E, N); 80 81 elsif Present (First_Formal (E)) then 82 Errint 83 ("intrinsic exception subprogram may not have parameters", 84 E, First_Formal (E)); 85 return; 86 87 elsif Etype (E) /= Standard_String then 88 Errint 89 ("return type of exception subprogram must be String", E, N); 90 return; 91 end if; 92 end Check_Exception_Function; 93 94 -------------------------- 95 -- Check_Intrinsic_Call -- 96 -------------------------- 97 98 procedure Check_Intrinsic_Call (N : Node_Id) is 99 Nam : constant Entity_Id := Entity (Name (N)); 100 Arg1 : constant Node_Id := First_Actual (N); 101 Typ : Entity_Id; 102 Rtyp : Entity_Id; 103 Cnam : Name_Id; 104 Unam : Node_Id; 105 106 begin 107 -- Set argument type if argument present 108 109 if Present (Arg1) then 110 Typ := Etype (Arg1); 111 Rtyp := Underlying_Type (Root_Type (Typ)); 112 end if; 113 114 -- Set intrinsic name (getting original name in the generic case) 115 116 Unam := Ultimate_Alias (Nam); 117 118 if Present (Parent (Unam)) 119 and then Present (Generic_Parent (Parent (Unam))) 120 then 121 Cnam := Chars (Generic_Parent (Parent (Unam))); 122 else 123 Cnam := Chars (Nam); 124 end if; 125 126 -- For Import_xxx calls, argument must be static string. A string 127 -- literal is legal even in Ada 83 mode, where such literals are 128 -- not static. 129 130 if Cnam = Name_Import_Address 131 or else 132 Cnam = Name_Import_Largest_Value 133 or else 134 Cnam = Name_Import_Value 135 then 136 if Etype (Arg1) = Any_Type 137 or else Raises_Constraint_Error (Arg1) 138 then 139 null; 140 141 elsif Nkind (Arg1) /= N_String_Literal 142 and then not Is_Static_Expression (Arg1) 143 then 144 Error_Msg_FE 145 ("call to & requires static string argument!", N, Nam); 146 Why_Not_Static (Arg1); 147 148 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then 149 Error_Msg_NE 150 ("call to & does not permit null string", N, Nam); 151 152 elsif OpenVMS_On_Target 153 and then String_Length (Strval (Expr_Value_S (Arg1))) > 31 154 then 155 Error_Msg_NE 156 ("argument in call to & must be 31 characters or less", N, Nam); 157 end if; 158 159 -- Check for the case of freeing a non-null object which will raise 160 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. 161 162 elsif Cnam = Name_Unchecked_Deallocation 163 and then Can_Never_Be_Null (Etype (Arg1)) 164 then 165 Error_Msg_N 166 ("freeing `NOT NULL` object will raise Constraint_Error??", N); 167 168 -- For unchecked deallocation, error to deallocate from empty pool. 169 -- Note: this test used to be in Exp_Intr as a warning, but AI 157 170 -- issues a binding interpretation that this should be an error, and 171 -- consequently it needs to be done in the semantic analysis so that 172 -- the error is issued even in semantics only mode. 173 174 elsif Cnam = Name_Unchecked_Deallocation 175 and then No_Pool_Assigned (Rtyp) 176 then 177 Error_Msg_N ("deallocation from empty storage pool!", N); 178 179 -- For now, no other special checks are required 180 181 else 182 return; 183 end if; 184 end Check_Intrinsic_Call; 185 186 ------------------------------ 187 -- Check_Intrinsic_Operator -- 188 ------------------------------ 189 190 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is 191 Ret : constant Entity_Id := Etype (E); 192 Nam : constant Name_Id := Chars (E); 193 T1 : Entity_Id; 194 T2 : Entity_Id; 195 196 begin 197 -- Arithmetic operators 198 199 if Nam = Name_Op_Add 200 or else 201 Nam = Name_Op_Subtract 202 or else 203 Nam = Name_Op_Multiply 204 or else 205 Nam = Name_Op_Divide 206 or else 207 Nam = Name_Op_Rem 208 or else 209 Nam = Name_Op_Mod 210 or else 211 Nam = Name_Op_Abs 212 then 213 T1 := Etype (First_Formal (E)); 214 215 if No (Next_Formal (First_Formal (E))) then 216 217 if Nam = Name_Op_Add 218 or else 219 Nam = Name_Op_Subtract 220 or else 221 Nam = Name_Op_Abs 222 then 223 T2 := T1; 224 225 -- Previous error in declaration 226 227 else 228 return; 229 end if; 230 231 else 232 T2 := Etype (Next_Formal (First_Formal (E))); 233 end if; 234 235 -- Same types, predefined operator will apply 236 237 if Root_Type (T1) = Root_Type (T2) 238 or else Root_Type (T1) = Root_Type (Ret) 239 then 240 null; 241 242 -- Expansion will introduce conversions if sizes are not equal 243 244 elsif Is_Integer_Type (Underlying_Type (T1)) 245 and then Is_Integer_Type (Underlying_Type (T2)) 246 and then Is_Integer_Type (Underlying_Type (Ret)) 247 then 248 null; 249 250 else 251 Errint 252 ("types of intrinsic operator operands do not match", E, N); 253 end if; 254 255 -- Comparison operators 256 257 elsif Nam = Name_Op_Eq 258 or else 259 Nam = Name_Op_Ge 260 or else 261 Nam = Name_Op_Gt 262 or else 263 Nam = Name_Op_Le 264 or else 265 Nam = Name_Op_Lt 266 or else 267 Nam = Name_Op_Ne 268 then 269 T1 := Etype (First_Formal (E)); 270 271 -- Return if previous error in declaration, otherwise get T2 type 272 273 if No (Next_Formal (First_Formal (E))) then 274 Check_Error_Detected; 275 return; 276 277 else 278 T2 := Etype (Next_Formal (First_Formal (E))); 279 end if; 280 281 if Root_Type (T1) /= Root_Type (T2) then 282 Errint 283 ("types of intrinsic operator must have the same size", E, N); 284 end if; 285 286 if Root_Type (Ret) /= Standard_Boolean then 287 Errint 288 ("result type of intrinsic comparison must be boolean", E, N); 289 end if; 290 291 -- Exponentiation 292 293 elsif Nam = Name_Op_Expon then 294 T1 := Etype (First_Formal (E)); 295 296 if No (Next_Formal (First_Formal (E))) then 297 298 -- Previous error in declaration 299 300 return; 301 302 else 303 T2 := Etype (Next_Formal (First_Formal (E))); 304 end if; 305 306 if not (Is_Integer_Type (T1) 307 or else 308 Is_Floating_Point_Type (T1)) 309 or else Root_Type (T1) /= Root_Type (Ret) 310 or else Root_Type (T2) /= Root_Type (Standard_Integer) 311 then 312 Errint ("incorrect operands for intrinsic operator", N, E); 313 end if; 314 315 -- All other operators (are there any?) are not handled 316 317 else 318 Errint ("incorrect context for ""Intrinsic"" convention", E, N); 319 return; 320 end if; 321 322 -- The type must be fully defined and numeric. 323 324 if No (Underlying_Type (T1)) 325 or else not Is_Numeric_Type (Underlying_Type (T1)) 326 then 327 Errint ("intrinsic operator can only apply to numeric types", E, N); 328 end if; 329 end Check_Intrinsic_Operator; 330 331 -------------------------------- 332 -- Check_Intrinsic_Subprogram -- 333 -------------------------------- 334 335 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is 336 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E)); 337 Nam : Name_Id; 338 339 begin 340 if Present (Spec) 341 and then Present (Generic_Parent (Spec)) 342 then 343 Nam := Chars (Generic_Parent (Spec)); 344 else 345 Nam := Chars (E); 346 end if; 347 348 -- Check name is valid intrinsic name 349 350 Get_Name_String (Nam); 351 352 if Name_Buffer (1) /= 'O' 353 and then Nam /= Name_Asm 354 and then Nam /= Name_To_Address 355 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name 356 then 357 Errint ("unrecognized intrinsic subprogram", E, N); 358 359 -- We always allow intrinsic specifications in language defined units 360 -- and in expanded code. We assume that the GNAT implementors know what 361 -- they are doing, and do not write or generate junk use of intrinsic! 362 363 elsif not Comes_From_Source (E) 364 or else not Comes_From_Source (N) 365 or else Is_Predefined_File_Name 366 (Unit_File_Name (Get_Source_Unit (N))) 367 then 368 null; 369 370 -- Shift cases. We allow user specification of intrinsic shift 371 -- operators for any numeric types. 372 373 elsif 374 Nam = Name_Rotate_Left 375 or else 376 Nam = Name_Rotate_Right 377 or else 378 Nam = Name_Shift_Left 379 or else 380 Nam = Name_Shift_Right 381 or else 382 Nam = Name_Shift_Right_Arithmetic 383 then 384 Check_Shift (E, N); 385 386 elsif 387 Nam = Name_Exception_Information 388 or else 389 Nam = Name_Exception_Message 390 or else 391 Nam = Name_Exception_Name 392 then 393 Check_Exception_Function (E, N); 394 395 elsif Nkind (E) = N_Defining_Operator_Symbol then 396 Check_Intrinsic_Operator (E, N); 397 398 elsif Nam = Name_File 399 or else Nam = Name_Line 400 or else Nam = Name_Source_Location 401 or else Nam = Name_Enclosing_Entity 402 then 403 null; 404 405 -- For now, no other intrinsic subprograms are recognized in user code 406 407 else 408 Errint ("incorrect context for ""Intrinsic"" convention", E, N); 409 end if; 410 end Check_Intrinsic_Subprogram; 411 412 ----------------- 413 -- Check_Shift -- 414 ----------------- 415 416 procedure Check_Shift (E : Entity_Id; N : Node_Id) is 417 Arg1 : Node_Id; 418 Arg2 : Node_Id; 419 Size : Nat; 420 Typ1 : Entity_Id; 421 Typ2 : Entity_Id; 422 Ptyp1 : Node_Id; 423 Ptyp2 : Node_Id; 424 425 begin 426 if not Ekind_In (E, E_Function, E_Generic_Function) then 427 Errint ("intrinsic shift subprogram must be a function", E, N); 428 return; 429 end if; 430 431 Arg1 := First_Formal (E); 432 433 if Present (Arg1) then 434 Arg2 := Next_Formal (Arg1); 435 else 436 Arg2 := Empty; 437 end if; 438 439 if Arg1 = Empty or else Arg2 = Empty then 440 Errint ("intrinsic shift function must have two arguments", E, N); 441 return; 442 end if; 443 444 Typ1 := Etype (Arg1); 445 Typ2 := Etype (Arg2); 446 447 Ptyp1 := Parameter_Type (Parent (Arg1)); 448 Ptyp2 := Parameter_Type (Parent (Arg2)); 449 450 if not Is_Integer_Type (Typ1) then 451 Errint ("first argument to shift must be integer type", Ptyp1, N); 452 return; 453 end if; 454 455 if Typ2 /= Standard_Natural then 456 Errint ("second argument to shift must be type Natural", Ptyp2, N); 457 return; 458 end if; 459 460 -- type'Size (not 'Object_Size!) must be one of the allowed values 461 462 Size := UI_To_Int (RM_Size (Typ1)); 463 464 if Size /= 8 and then 465 Size /= 16 and then 466 Size /= 32 and then 467 Size /= 64 468 then 469 Errint 470 ("first argument for shift must have size 8, 16, 32 or 64", 471 Ptyp1, N); 472 return; 473 474 elsif Non_Binary_Modulus (Typ1) then 475 Errint 476 ("shifts not allowed for non-binary modular types", Ptyp1, N); 477 478 elsif Etype (Arg1) /= Etype (E) then 479 Errint 480 ("first argument of shift must match return type", Ptyp1, N); 481 return; 482 end if; 483 end Check_Shift; 484 485 ------------ 486 -- Errint -- 487 ------------ 488 489 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is 490 begin 491 Error_Msg_N (Msg, S); 492 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N); 493 end Errint; 494 495end Sem_Intr; 496