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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27-- Processing for intrinsic subprogram declarations 28 29with Atree; use Atree; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Fname; use Fname; 33with Lib; use Lib; 34with Namet; use Namet; 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 58 -- that the types involved have the same size. 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 Ekind (E) /= E_Function 78 and then Ekind (E) /= E_Generic_Function 79 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 Cnam : constant Name_Id := Chars (Nam); 103 Arg1 : constant Node_Id := First_Actual (N); 104 105 begin 106 -- For Import_xxx calls, argument must be static string 107 108 if Cnam = Name_Import_Address 109 or else 110 Cnam = Name_Import_Largest_Value 111 or else 112 Cnam = Name_Import_Value 113 then 114 if Etype (Arg1) = Any_Type 115 or else Raises_Constraint_Error (Arg1) 116 then 117 null; 118 119 elsif not Is_Static_Expression (Arg1) then 120 Error_Msg_FE 121 ("call to & requires static string argument!", N, Nam); 122 Why_Not_Static (Arg1); 123 124 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then 125 Error_Msg_NE 126 ("call to & does not permit null string", N, Nam); 127 128 elsif OpenVMS_On_Target 129 and then String_Length (Strval (Expr_Value_S (Arg1))) > 31 130 then 131 Error_Msg_NE 132 ("argument in call to & must be 31 characters or less", N, Nam); 133 end if; 134 135 -- For now, no other special checks are required 136 137 else 138 return; 139 end if; 140 end Check_Intrinsic_Call; 141 142 ------------------------------ 143 -- Check_Intrinsic_Operator -- 144 ------------------------------ 145 146 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is 147 Ret : constant Entity_Id := Etype (E); 148 Nam : constant Name_Id := Chars (E); 149 T1 : Entity_Id; 150 T2 : Entity_Id; 151 152 begin 153 -- Aritnmetic operators 154 155 if Nam = Name_Op_Add 156 or else 157 Nam = Name_Op_Subtract 158 or else 159 Nam = Name_Op_Multiply 160 or else 161 Nam = Name_Op_Divide 162 or else 163 Nam = Name_Op_Rem 164 or else 165 Nam = Name_Op_Mod 166 or else 167 Nam = Name_Op_Abs 168 then 169 T1 := Etype (First_Formal (E)); 170 171 if No (Next_Formal (First_Formal (E))) then 172 173 if Nam = Name_Op_Add 174 or else 175 Nam = Name_Op_Subtract 176 or else 177 Nam = Name_Op_Abs 178 then 179 T2 := T1; 180 181 else 182 -- Previous error in declaration 183 184 return; 185 end if; 186 187 else 188 T2 := Etype (Next_Formal (First_Formal (E))); 189 end if; 190 191 if Root_Type (T1) /= Root_Type (T2) 192 or else Root_Type (T1) /= Root_Type (Ret) 193 then 194 Errint 195 ("types of intrinsic operator must have the same size", E, N); 196 end if; 197 198 -- Comparison operators 199 200 elsif Nam = Name_Op_Eq 201 or else 202 Nam = Name_Op_Ge 203 or else 204 Nam = Name_Op_Gt 205 or else 206 Nam = Name_Op_Le 207 or else 208 Nam = Name_Op_Lt 209 or else 210 Nam = Name_Op_Ne 211 then 212 T1 := Etype (First_Formal (E)); 213 214 if No (Next_Formal (First_Formal (E))) then 215 216 -- Previous error in declaration 217 218 return; 219 220 else 221 T2 := Etype (Next_Formal (First_Formal (E))); 222 end if; 223 224 if Root_Type (T1) /= Root_Type (T2) then 225 Errint 226 ("types of intrinsic operator must have the same size", E, N); 227 end if; 228 229 if Root_Type (Ret) /= Standard_Boolean then 230 Errint 231 ("result type of intrinsic comparison must be boolean", E, N); 232 end if; 233 234 -- Exponentiation 235 236 elsif Nam = Name_Op_Expon then 237 T1 := Etype (First_Formal (E)); 238 239 if No (Next_Formal (First_Formal (E))) then 240 241 -- Previous error in declaration 242 243 return; 244 245 else 246 T2 := Etype (Next_Formal (First_Formal (E))); 247 end if; 248 249 if not (Is_Integer_Type (T1) 250 or else 251 Is_Floating_Point_Type (T1)) 252 or else Root_Type (T1) /= Root_Type (Ret) 253 or else Root_Type (T2) /= Root_Type (Standard_Integer) 254 then 255 Errint ("incorrect operands for intrinsic operator", N, E); 256 end if; 257 258 -- All other operators (are there any?) are not handled 259 260 else 261 Errint ("incorrect context for ""Intrinsic"" convention", E, N); 262 return; 263 end if; 264 265 if not Is_Numeric_Type (T1) then 266 Errint ("intrinsic operator can only apply to numeric types", E, N); 267 end if; 268 end Check_Intrinsic_Operator; 269 270 -------------------------------- 271 -- Check_Intrinsic_Subprogram -- 272 -------------------------------- 273 274 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is 275 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E)); 276 Nam : Name_Id; 277 278 begin 279 if Present (Spec) 280 and then Present (Generic_Parent (Spec)) 281 then 282 Nam := Chars (Generic_Parent (Spec)); 283 else 284 Nam := Chars (E); 285 end if; 286 287 -- Check name is valid intrinsic name 288 289 Get_Name_String (Nam); 290 291 if Name_Buffer (1) /= 'O' 292 and then Nam /= Name_Asm 293 and then Nam /= Name_To_Address 294 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name 295 then 296 Errint ("unrecognized intrinsic subprogram", E, N); 297 298 -- We always allow intrinsic specifications in language defined units 299 -- and in expanded code. We assume that the GNAT implemetors know what 300 -- they are doing, and do not write or generate junk use of intrinsic! 301 302 elsif not Comes_From_Source (E) 303 or else not Comes_From_Source (N) 304 or else Is_Predefined_File_Name 305 (Unit_File_Name (Get_Source_Unit (N))) 306 then 307 null; 308 309 -- Shift cases. We allow user specification of intrinsic shift 310 -- operators for any numeric types. 311 312 elsif 313 Nam = Name_Rotate_Left 314 or else 315 Nam = Name_Rotate_Right 316 or else 317 Nam = Name_Shift_Left 318 or else 319 Nam = Name_Shift_Right 320 or else 321 Nam = Name_Shift_Right_Arithmetic 322 then 323 Check_Shift (E, N); 324 325 elsif 326 Nam = Name_Exception_Information 327 or else 328 Nam = Name_Exception_Message 329 or else 330 Nam = Name_Exception_Name 331 then 332 Check_Exception_Function (E, N); 333 334 elsif Nkind (E) = N_Defining_Operator_Symbol then 335 Check_Intrinsic_Operator (E, N); 336 337 elsif Nam = Name_File 338 or else Nam = Name_Line 339 or else Nam = Name_Source_Location 340 or else Nam = Name_Enclosing_Entity 341 then 342 null; 343 344 -- For now, no other intrinsic subprograms are recognized in user code 345 346 else 347 Errint ("incorrect context for ""Intrinsic"" convention", E, N); 348 end if; 349 end Check_Intrinsic_Subprogram; 350 351 ----------------- 352 -- Check_Shift -- 353 ----------------- 354 355 procedure Check_Shift (E : Entity_Id; N : Node_Id) is 356 Arg1 : Node_Id; 357 Arg2 : Node_Id; 358 Size : Nat; 359 Typ1 : Entity_Id; 360 Typ2 : Entity_Id; 361 Ptyp1 : Node_Id; 362 Ptyp2 : Node_Id; 363 364 begin 365 if Ekind (E) /= E_Function 366 and then Ekind (E) /= E_Generic_Function 367 then 368 Errint ("intrinsic shift subprogram must be a function", E, N); 369 return; 370 end if; 371 372 Arg1 := First_Formal (E); 373 374 if Present (Arg1) then 375 Arg2 := Next_Formal (Arg1); 376 else 377 Arg2 := Empty; 378 end if; 379 380 if Arg1 = Empty or else Arg2 = Empty then 381 Errint ("intrinsic shift function must have two arguments", E, N); 382 return; 383 end if; 384 385 Typ1 := Etype (Arg1); 386 Typ2 := Etype (Arg2); 387 388 Ptyp1 := Parameter_Type (Parent (Arg1)); 389 Ptyp2 := Parameter_Type (Parent (Arg2)); 390 391 if not Is_Integer_Type (Typ1) then 392 Errint ("first argument to shift must be integer type", Ptyp1, N); 393 return; 394 end if; 395 396 if Typ2 /= Standard_Natural then 397 Errint ("second argument to shift must be type Natural", Ptyp2, N); 398 return; 399 end if; 400 401 Size := UI_To_Int (Esize (Typ1)); 402 403 if Size /= 8 404 and then Size /= 16 405 and then Size /= 32 406 and then Size /= 64 407 then 408 Errint 409 ("first argument for shift must have size 8, 16, 32 or 64", 410 Ptyp1, N); 411 return; 412 413 elsif Is_Modular_Integer_Type (Typ1) 414 and then Non_Binary_Modulus (Typ1) 415 then 416 Errint 417 ("shifts not allowed for non-binary modular types", 418 Ptyp1, N); 419 420 elsif Etype (Arg1) /= Etype (E) then 421 Errint 422 ("first argument of shift must match return type", Ptyp1, N); 423 return; 424 end if; 425 end Check_Shift; 426 427 ------------ 428 -- Errint -- 429 ------------ 430 431 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is 432 begin 433 Error_Msg_N (Msg, S); 434 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N); 435 end Errint; 436 437end Sem_Intr; 438