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-2013, 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 Nam_In (Cnam, Name_Import_Address, 131 Name_Import_Largest_Value, 132 Name_Import_Value) 133 then 134 if Etype (Arg1) = Any_Type 135 or else Raises_Constraint_Error (Arg1) 136 then 137 null; 138 139 elsif Nkind (Arg1) /= N_String_Literal 140 and then not Is_Static_Expression (Arg1) 141 then 142 Error_Msg_FE 143 ("call to & requires static string argument!", N, Nam); 144 Why_Not_Static (Arg1); 145 146 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then 147 Error_Msg_NE 148 ("call to & does not permit null string", N, Nam); 149 150 elsif OpenVMS_On_Target 151 and then String_Length (Strval (Expr_Value_S (Arg1))) > 31 152 then 153 Error_Msg_NE 154 ("argument in call to & must be 31 characters or less", N, Nam); 155 end if; 156 157 -- Check for the case of freeing a non-null object which will raise 158 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. 159 160 elsif Cnam = Name_Unchecked_Deallocation 161 and then Can_Never_Be_Null (Etype (Arg1)) 162 then 163 Error_Msg_N 164 ("freeing `NOT NULL` object will raise Constraint_Error??", N); 165 166 -- For unchecked deallocation, error to deallocate from empty pool. 167 -- Note: this test used to be in Exp_Intr as a warning, but AI 157 168 -- issues a binding interpretation that this should be an error, and 169 -- consequently it needs to be done in the semantic analysis so that 170 -- the error is issued even in semantics only mode. 171 172 elsif Cnam = Name_Unchecked_Deallocation 173 and then No_Pool_Assigned (Rtyp) 174 then 175 Error_Msg_N ("deallocation from empty storage pool!", N); 176 177 -- For now, no other special checks are required 178 179 else 180 return; 181 end if; 182 end Check_Intrinsic_Call; 183 184 ------------------------------ 185 -- Check_Intrinsic_Operator -- 186 ------------------------------ 187 188 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is 189 Ret : constant Entity_Id := Etype (E); 190 Nam : constant Name_Id := Chars (E); 191 T1 : Entity_Id; 192 T2 : Entity_Id; 193 194 begin 195 -- Arithmetic operators 196 197 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply, 198 Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs) 199 then 200 T1 := Etype (First_Formal (E)); 201 202 if No (Next_Formal (First_Formal (E))) then 203 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then 204 T2 := T1; 205 206 -- Previous error in declaration 207 208 else 209 return; 210 end if; 211 212 else 213 T2 := Etype (Next_Formal (First_Formal (E))); 214 end if; 215 216 -- Same types, predefined operator will apply 217 218 if Root_Type (T1) = Root_Type (T2) 219 or else Root_Type (T1) = Root_Type (Ret) 220 then 221 null; 222 223 -- Expansion will introduce conversions if sizes are not equal 224 225 elsif Is_Integer_Type (Underlying_Type (T1)) 226 and then Is_Integer_Type (Underlying_Type (T2)) 227 and then Is_Integer_Type (Underlying_Type (Ret)) 228 then 229 null; 230 231 else 232 Errint 233 ("types of intrinsic operator operands do not match", E, N); 234 end if; 235 236 -- Comparison operators 237 238 elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le, 239 Name_Op_Lt, Name_Op_Ne) 240 then 241 T1 := Etype (First_Formal (E)); 242 243 -- Return if previous error in declaration, otherwise get T2 type 244 245 if No (Next_Formal (First_Formal (E))) then 246 Check_Error_Detected; 247 return; 248 249 else 250 T2 := Etype (Next_Formal (First_Formal (E))); 251 end if; 252 253 if Root_Type (T1) /= Root_Type (T2) then 254 Errint 255 ("types of intrinsic operator must have the same size", E, N); 256 end if; 257 258 if Root_Type (Ret) /= Standard_Boolean then 259 Errint 260 ("result type of intrinsic comparison must be boolean", E, N); 261 end if; 262 263 -- Exponentiation 264 265 elsif Nam = Name_Op_Expon then 266 T1 := Etype (First_Formal (E)); 267 268 if No (Next_Formal (First_Formal (E))) then 269 270 -- Previous error in declaration 271 272 return; 273 274 else 275 T2 := Etype (Next_Formal (First_Formal (E))); 276 end if; 277 278 if not (Is_Integer_Type (T1) 279 or else 280 Is_Floating_Point_Type (T1)) 281 or else Root_Type (T1) /= Root_Type (Ret) 282 or else Root_Type (T2) /= Root_Type (Standard_Integer) 283 then 284 Errint ("incorrect operands for intrinsic operator", N, E); 285 end if; 286 287 -- All other operators (are there any?) are not handled 288 289 else 290 Errint ("incorrect context for ""Intrinsic"" convention", E, N); 291 return; 292 end if; 293 294 -- The type must be fully defined and numeric. 295 296 if No (Underlying_Type (T1)) 297 or else not Is_Numeric_Type (Underlying_Type (T1)) 298 then 299 Errint ("intrinsic operator can only apply to numeric types", E, N); 300 end if; 301 end Check_Intrinsic_Operator; 302 303 -------------------------------- 304 -- Check_Intrinsic_Subprogram -- 305 -------------------------------- 306 307 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is 308 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E)); 309 Nam : Name_Id; 310 311 begin 312 if Present (Spec) 313 and then Present (Generic_Parent (Spec)) 314 then 315 Nam := Chars (Generic_Parent (Spec)); 316 else 317 Nam := Chars (E); 318 end if; 319 320 -- Check name is valid intrinsic name 321 322 Get_Name_String (Nam); 323 324 if Name_Buffer (1) /= 'O' 325 and then Nam /= Name_Asm 326 and then Nam /= Name_To_Address 327 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name 328 then 329 Errint ("unrecognized intrinsic subprogram", E, N); 330 331 -- Shift cases. We allow user specification of intrinsic shift operators 332 -- for any numeric types. 333 334 elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, 335 Name_Shift_Right, Name_Shift_Right_Arithmetic) 336 then 337 Check_Shift (E, N); 338 339 -- We always allow intrinsic specifications in language defined units 340 -- and in expanded code. We assume that the GNAT implementors know what 341 -- they are doing, and do not write or generate junk use of intrinsic. 342 343 elsif not Comes_From_Source (E) 344 or else not Comes_From_Source (N) 345 or else Is_Predefined_File_Name 346 (Unit_File_Name (Get_Source_Unit (N))) 347 then 348 null; 349 350 -- Exception functions 351 352 elsif Nam_In (Nam, Name_Exception_Information, 353 Name_Exception_Message, 354 Name_Exception_Name) 355 then 356 Check_Exception_Function (E, N); 357 358 -- Intrinsic operators 359 360 elsif Nkind (E) = N_Defining_Operator_Symbol then 361 Check_Intrinsic_Operator (E, N); 362 363 -- Source_Location and navigation functions 364 365 elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, 366 Name_Enclosing_Entity) 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); 437 return; 438 439 elsif Non_Binary_Modulus (Typ1) then 440 Errint 441 ("shifts not allowed for non-binary modular types", Ptyp1, N); 442 443 elsif Etype (Arg1) /= Etype (E) then 444 Errint 445 ("first argument of shift must match return type", Ptyp1, N); 446 return; 447 end if; 448 449 Set_Has_Shift_Operator (Base_Type (Typ1)); 450 end Check_Shift; 451 452 ------------ 453 -- Errint -- 454 ------------ 455 456 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is 457 begin 458 Error_Msg_N (Msg, S); 459 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N); 460 end Errint; 461 462end Sem_Intr; 463