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