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