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