1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- R E S T R I C T -- 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 27with Atree; use Atree; 28with Casing; use Casing; 29with Errout; use Errout; 30with Fname; use Fname; 31with Fname.UF; use Fname.UF; 32with Lib; use Lib; 33with Namet; use Namet; 34with Sinput; use Sinput; 35with Uname; use Uname; 36 37package body Restrict is 38 39 ----------------------- 40 -- Local Subprograms -- 41 ----------------------- 42 43 procedure Restriction_Msg (Msg : String; R : String; N : Node_Id); 44 -- Output error message at node N with given text, replacing the 45 -- '%' in the message with the name of the restriction given as R, 46 -- cased according to the current identifier casing. We do not use 47 -- the normal insertion mechanism, since this requires an entry 48 -- in the Names table, and this table will be locked if we are 49 -- generating a message from gigi. 50 51 function Suppress_Restriction_Message (N : Node_Id) return Boolean; 52 -- N is the node for a possible restriction violation message, but 53 -- the message is to be suppressed if this is an internal file and 54 -- this file is not the main unit. 55 56 ------------------- 57 -- Abort_Allowed -- 58 ------------------- 59 60 function Abort_Allowed return Boolean is 61 begin 62 if Restrictions (No_Abort_Statements) 63 and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0 64 then 65 return False; 66 67 else 68 return True; 69 end if; 70 end Abort_Allowed; 71 72 ------------------------------------ 73 -- Check_Elaboration_Code_Allowed -- 74 ------------------------------------ 75 76 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is 77 begin 78 -- Avoid calling Namet.Unlock/Lock except when there is an error. 79 -- Even in the error case it is a bit dubious, either gigi needs 80 -- the table locked or it does not! ??? 81 82 if Restrictions (No_Elaboration_Code) 83 and then not Suppress_Restriction_Message (N) 84 then 85 Namet.Unlock; 86 Check_Restriction (Restriction_Id'(No_Elaboration_Code), N); 87 Namet.Lock; 88 end if; 89 end Check_Elaboration_Code_Allowed; 90 91 ---------------------------------- 92 -- Check_No_Implicit_Heap_Alloc -- 93 ---------------------------------- 94 95 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is 96 begin 97 Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N); 98 end Check_No_Implicit_Heap_Alloc; 99 100 --------------------------- 101 -- Check_Restricted_Unit -- 102 --------------------------- 103 104 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is 105 begin 106 if Suppress_Restriction_Message (N) then 107 return; 108 109 elsif Is_Spec_Name (U) then 110 declare 111 Fnam : constant File_Name_Type := 112 Get_File_Name (U, Subunit => False); 113 R_Id : Restriction_Id; 114 115 begin 116 if not Is_Predefined_File_Name (Fnam) then 117 return; 118 119 -- Ada child unit spec, needs checking against list 120 121 else 122 -- Pad name to 8 characters with blanks 123 124 Get_Name_String (Fnam); 125 Name_Len := Name_Len - 4; 126 127 while Name_Len < 8 loop 128 Name_Len := Name_Len + 1; 129 Name_Buffer (Name_Len) := ' '; 130 end loop; 131 132 for J in Unit_Array'Range loop 133 if Name_Len = 8 134 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm 135 then 136 R_Id := Unit_Array (J).Res_Id; 137 Violations (R_Id) := True; 138 139 if Restrictions (R_Id) then 140 declare 141 S : constant String := Restriction_Id'Image (R_Id); 142 143 begin 144 Error_Msg_Unit_1 := U; 145 146 Error_Msg_N 147 ("|dependence on $ not allowed,", N); 148 149 Name_Buffer (1 .. S'Last) := S; 150 Name_Len := S'Length; 151 Set_Casing (All_Lower_Case); 152 Error_Msg_Name_1 := Name_Enter; 153 Error_Msg_Sloc := Restrictions_Loc (R_Id); 154 155 Error_Msg_N 156 ("\|violates pragma Restriction (%) #", N); 157 return; 158 end; 159 end if; 160 end if; 161 end loop; 162 end if; 163 end; 164 end if; 165 end Check_Restricted_Unit; 166 167 ----------------------- 168 -- Check_Restriction -- 169 ----------------------- 170 171 -- Case of simple identifier (no parameter) 172 173 procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is 174 Rimage : constant String := Restriction_Id'Image (R); 175 176 begin 177 Violations (R) := True; 178 179 if (Restrictions (R) or Restriction_Warnings (R)) 180 and then not Suppress_Restriction_Message (N) 181 then 182 -- Output proper message. If this is just a case of 183 -- a restriction warning, then we output a warning msg 184 185 if not Restrictions (R) then 186 Restriction_Msg 187 ("?violation of restriction %", Rimage, N); 188 189 -- If this is a real restriction violation, then generate 190 -- a non-serious message with appropriate location. 191 192 else 193 Error_Msg_Sloc := Restrictions_Loc (R); 194 195 -- If we have a location for the Restrictions pragma, output it 196 197 if Error_Msg_Sloc > No_Location 198 or else Error_Msg_Sloc = System_Location 199 then 200 Restriction_Msg 201 ("|violation of restriction %#", Rimage, N); 202 203 -- Otherwise restriction was implicit (e.g. set by another pragma) 204 205 else 206 Restriction_Msg 207 ("|violation of implicit restriction %", Rimage, N); 208 end if; 209 end if; 210 end if; 211 end Check_Restriction; 212 213 -- Case where a parameter is present, with a count 214 215 procedure Check_Restriction 216 (R : Restriction_Parameter_Id; 217 V : Uint; 218 N : Node_Id) 219 is 220 begin 221 if Restriction_Parameters (R) /= No_Uint 222 and then V > Restriction_Parameters (R) 223 and then not Suppress_Restriction_Message (N) 224 then 225 declare 226 S : constant String := Restriction_Parameter_Id'Image (R); 227 begin 228 Name_Buffer (1 .. S'Last) := S; 229 Name_Len := S'Length; 230 Set_Casing (All_Lower_Case); 231 Error_Msg_Name_1 := Name_Enter; 232 Error_Msg_Sloc := Restriction_Parameters_Loc (R); 233 Error_Msg_N ("|maximum value exceeded for restriction %#", N); 234 end; 235 end if; 236 end Check_Restriction; 237 238 -- Case where a parameter is present, no count given 239 240 procedure Check_Restriction 241 (R : Restriction_Parameter_Id; 242 N : Node_Id) 243 is 244 begin 245 if Restriction_Parameters (R) = Uint_0 246 and then not Suppress_Restriction_Message (N) 247 then 248 declare 249 S : constant String := Restriction_Parameter_Id'Image (R); 250 begin 251 Name_Buffer (1 .. S'Last) := S; 252 Name_Len := S'Length; 253 Set_Casing (All_Lower_Case); 254 Error_Msg_Name_1 := Name_Enter; 255 Error_Msg_Sloc := Restriction_Parameters_Loc (R); 256 Error_Msg_N ("|maximum value exceeded for restriction %#", N); 257 end; 258 end if; 259 end Check_Restriction; 260 261 ------------------------------------------- 262 -- Compilation_Unit_Restrictions_Restore -- 263 ------------------------------------------- 264 265 procedure Compilation_Unit_Restrictions_Restore 266 (R : Save_Compilation_Unit_Restrictions) 267 is 268 begin 269 for J in Compilation_Unit_Restrictions loop 270 Restrictions (J) := R (J); 271 end loop; 272 end Compilation_Unit_Restrictions_Restore; 273 274 ---------------------------------------- 275 -- Compilation_Unit_Restrictions_Save -- 276 ---------------------------------------- 277 278 function Compilation_Unit_Restrictions_Save 279 return Save_Compilation_Unit_Restrictions 280 is 281 R : Save_Compilation_Unit_Restrictions; 282 283 begin 284 for J in Compilation_Unit_Restrictions loop 285 R (J) := Restrictions (J); 286 Restrictions (J) := False; 287 end loop; 288 289 return R; 290 end Compilation_Unit_Restrictions_Save; 291 292 ------------------------ 293 -- Get_Restriction_Id -- 294 ------------------------ 295 296 function Get_Restriction_Id 297 (N : Name_Id) 298 return Restriction_Id 299 is 300 J : Restriction_Id; 301 302 begin 303 Get_Name_String (N); 304 Set_Casing (All_Upper_Case); 305 306 J := Restriction_Id'First; 307 while J /= Not_A_Restriction_Id loop 308 declare 309 S : constant String := Restriction_Id'Image (J); 310 311 begin 312 exit when S = Name_Buffer (1 .. Name_Len); 313 end; 314 315 J := Restriction_Id'Succ (J); 316 end loop; 317 318 return J; 319 end Get_Restriction_Id; 320 321 ---------------------------------- 322 -- Get_Restriction_Parameter_Id -- 323 ---------------------------------- 324 325 function Get_Restriction_Parameter_Id 326 (N : Name_Id) 327 return Restriction_Parameter_Id 328 is 329 J : Restriction_Parameter_Id; 330 331 begin 332 Get_Name_String (N); 333 Set_Casing (All_Upper_Case); 334 335 J := Restriction_Parameter_Id'First; 336 while J /= Not_A_Restriction_Parameter_Id loop 337 declare 338 S : constant String := Restriction_Parameter_Id'Image (J); 339 340 begin 341 exit when S = Name_Buffer (1 .. Name_Len); 342 end; 343 344 J := Restriction_Parameter_Id'Succ (J); 345 end loop; 346 347 return J; 348 end Get_Restriction_Parameter_Id; 349 350 ------------------------------- 351 -- No_Exception_Handlers_Set -- 352 ------------------------------- 353 354 function No_Exception_Handlers_Set return Boolean is 355 begin 356 return Restrictions (No_Exception_Handlers); 357 end No_Exception_Handlers_Set; 358 359 ------------------------ 360 -- Restricted_Profile -- 361 ------------------------ 362 363 -- This implementation must be coordinated with Set_Restricted_Profile 364 365 function Restricted_Profile return Boolean is 366 begin 367 return Restrictions (No_Abort_Statements) 368 and then Restrictions (No_Asynchronous_Control) 369 and then Restrictions (No_Entry_Queue) 370 and then Restrictions (No_Task_Hierarchy) 371 and then Restrictions (No_Task_Allocators) 372 and then Restrictions (No_Dynamic_Priorities) 373 and then Restrictions (No_Terminate_Alternatives) 374 and then Restrictions (No_Dynamic_Interrupts) 375 and then Restrictions (No_Protected_Type_Allocators) 376 and then Restrictions (No_Local_Protected_Objects) 377 and then Restrictions (No_Requeue) 378 and then Restrictions (No_Task_Attributes) 379 and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0 380 and then Restriction_Parameters (Max_Task_Entries) = 0 381 and then Restriction_Parameters (Max_Protected_Entries) <= 1 382 and then Restriction_Parameters (Max_Select_Alternatives) = 0; 383 end Restricted_Profile; 384 385 --------------------- 386 -- Restriction_Msg -- 387 --------------------- 388 389 procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is 390 B : String (1 .. Msg'Length + 2 * R'Length + 1); 391 P : Natural := 1; 392 393 begin 394 Name_Buffer (1 .. R'Last) := R; 395 Name_Len := R'Length; 396 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); 397 398 P := 0; 399 for J in Msg'Range loop 400 if Msg (J) = '%' then 401 P := P + 1; 402 B (P) := '`'; 403 404 -- Put characters of image in message, quoting upper case letters 405 406 for J in 1 .. Name_Len loop 407 if Name_Buffer (J) in 'A' .. 'Z' then 408 P := P + 1; 409 B (P) := '''; 410 end if; 411 412 P := P + 1; 413 B (P) := Name_Buffer (J); 414 end loop; 415 416 P := P + 1; 417 B (P) := '`'; 418 419 else 420 P := P + 1; 421 B (P) := Msg (J); 422 end if; 423 end loop; 424 425 Error_Msg_N (B (1 .. P), N); 426 end Restriction_Msg; 427 428 ------------------- 429 -- Set_Ravenscar -- 430 ------------------- 431 432 procedure Set_Ravenscar (N : Node_Id) is 433 Loc : constant Source_Ptr := Sloc (N); 434 435 begin 436 Set_Restricted_Profile (N); 437 Restrictions (Boolean_Entry_Barriers) := True; 438 Restrictions (No_Select_Statements) := True; 439 Restrictions (No_Calendar) := True; 440 Restrictions (No_Entry_Queue) := True; 441 Restrictions (No_Relative_Delay) := True; 442 Restrictions (No_Task_Termination) := True; 443 Restrictions (No_Implicit_Heap_Allocations) := True; 444 445 Restrictions_Loc (Boolean_Entry_Barriers) := Loc; 446 Restrictions_Loc (No_Select_Statements) := Loc; 447 Restrictions_Loc (No_Calendar) := Loc; 448 Restrictions_Loc (No_Entry_Queue) := Loc; 449 Restrictions_Loc (No_Relative_Delay) := Loc; 450 Restrictions_Loc (No_Task_Termination) := Loc; 451 Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc; 452 end Set_Ravenscar; 453 454 ---------------------------- 455 -- Set_Restricted_Profile -- 456 ---------------------------- 457 458 -- This must be coordinated with Restricted_Profile 459 460 procedure Set_Restricted_Profile (N : Node_Id) is 461 Loc : constant Source_Ptr := Sloc (N); 462 463 begin 464 Restrictions (No_Abort_Statements) := True; 465 Restrictions (No_Asynchronous_Control) := True; 466 Restrictions (No_Entry_Queue) := True; 467 Restrictions (No_Task_Hierarchy) := True; 468 Restrictions (No_Task_Allocators) := True; 469 Restrictions (No_Dynamic_Priorities) := True; 470 Restrictions (No_Terminate_Alternatives) := True; 471 Restrictions (No_Dynamic_Interrupts) := True; 472 Restrictions (No_Protected_Type_Allocators) := True; 473 Restrictions (No_Local_Protected_Objects) := True; 474 Restrictions (No_Requeue) := True; 475 Restrictions (No_Task_Attributes) := True; 476 477 Restrictions_Loc (No_Abort_Statements) := Loc; 478 Restrictions_Loc (No_Asynchronous_Control) := Loc; 479 Restrictions_Loc (No_Entry_Queue) := Loc; 480 Restrictions_Loc (No_Task_Hierarchy) := Loc; 481 Restrictions_Loc (No_Task_Allocators) := Loc; 482 Restrictions_Loc (No_Dynamic_Priorities) := Loc; 483 Restrictions_Loc (No_Terminate_Alternatives) := Loc; 484 Restrictions_Loc (No_Dynamic_Interrupts) := Loc; 485 Restrictions_Loc (No_Protected_Type_Allocators) := Loc; 486 Restrictions_Loc (No_Local_Protected_Objects) := Loc; 487 Restrictions_Loc (No_Requeue) := Loc; 488 Restrictions_Loc (No_Task_Attributes) := Loc; 489 490 Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0; 491 Restriction_Parameters (Max_Task_Entries) := Uint_0; 492 Restriction_Parameters (Max_Select_Alternatives) := Uint_0; 493 494 if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then 495 Restriction_Parameters (Max_Protected_Entries) := Uint_1; 496 end if; 497 end Set_Restricted_Profile; 498 499 ---------------------------------- 500 -- Suppress_Restriction_Message -- 501 ---------------------------------- 502 503 function Suppress_Restriction_Message (N : Node_Id) return Boolean is 504 begin 505 -- We only output messages for the extended main source unit 506 507 if In_Extended_Main_Source_Unit (N) then 508 return False; 509 510 -- If loaded by rtsfind, then suppress message 511 512 elsif Sloc (N) <= No_Location then 513 return True; 514 515 -- Otherwise suppress message if internal file 516 517 else 518 return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); 519 end if; 520 end Suppress_Restriction_Message; 521 522 --------------------- 523 -- Tasking_Allowed -- 524 --------------------- 525 526 function Tasking_Allowed return Boolean is 527 begin 528 return Restriction_Parameters (Max_Tasks) /= 0 529 and then not Restrictions (No_Tasking); 530 end Tasking_Allowed; 531 532end Restrict; 533