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