1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- T A R G P A R M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2012, 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 26with Csets; use Csets; 27with Opt; use Opt; 28with Osint; use Osint; 29with Output; use Output; 30 31package body Targparm is 32 use ASCII; 33 34 Parameters_Obtained : Boolean := False; 35 -- Set True after first call to Get_Target_Parameters. Used to avoid 36 -- reading system.ads more than once, since it cannot change. 37 38 -- The following array defines a tag name for each entry 39 40 type Targparm_Tags is 41 (AAM, -- AAMP 42 ACR, -- Always_Compatible_Rep 43 ASD, -- Atomic_Sync_Default 44 BDC, -- Backend_Divide_Checks 45 BOC, -- Backend_Overflow_Checks 46 CLA, -- Command_Line_Args 47 CLI, -- CLI (.NET) 48 CRT, -- Configurable_Run_Times 49 D32, -- Duration_32_Bits 50 DEN, -- Denorm 51 EXS, -- Exit_Status_Supported 52 FEL, -- Frontend_Layout 53 FFO, -- Fractional_Fixed_Ops 54 JVM, -- JVM 55 MOV, -- Machine_Overflows 56 MRN, -- Machine_Rounds 57 PAS, -- Preallocated_Stacks 58 RTX, -- RTX_RTSS_Kernel_Module 59 SAG, -- Support_Aggregates 60 SAP, -- Support_Atomic_Primitives 61 SCA, -- Support_Composite_Assign 62 SCC, -- Support_Composite_Compare 63 SCD, -- Stack_Check_Default 64 SCL, -- Stack_Check_Limits 65 SCP, -- Stack_Check_Probes 66 SLS, -- Support_Long_Shifts 67 SNZ, -- Signed_Zeros 68 SSL, -- Suppress_Standard_Library 69 UAM, -- Use_Ada_Main_Program_Name 70 VMS, -- OpenVMS 71 ZCD); -- ZCX_By_Default 72 73 Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); 74 -- Flag is set True if corresponding parameter is scanned 75 76 -- The following list of string constants gives the parameter names 77 78 AAM_Str : aliased constant Source_Buffer := "AAMP"; 79 ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep"; 80 ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default"; 81 BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; 82 BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; 83 CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; 84 CLI_Str : aliased constant Source_Buffer := "CLI"; 85 CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; 86 D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; 87 DEN_Str : aliased constant Source_Buffer := "Denorm"; 88 EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported"; 89 FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; 90 FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; 91 JVM_Str : aliased constant Source_Buffer := "JVM"; 92 MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; 93 MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; 94 PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; 95 RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module"; 96 SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; 97 SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives"; 98 SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; 99 SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare"; 100 SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default"; 101 SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits"; 102 SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes"; 103 SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts"; 104 SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros"; 105 SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library"; 106 UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; 107 VMS_Str : aliased constant Source_Buffer := "OpenVMS"; 108 ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; 109 110 -- The following defines a set of pointers to the above strings, 111 -- indexed by the tag values. 112 113 type Buffer_Ptr is access constant Source_Buffer; 114 Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr := 115 (AAM_Str'Access, 116 ACR_Str'Access, 117 ASD_Str'Access, 118 BDC_Str'Access, 119 BOC_Str'Access, 120 CLA_Str'Access, 121 CLI_Str'Access, 122 CRT_Str'Access, 123 D32_Str'Access, 124 DEN_Str'Access, 125 EXS_Str'Access, 126 FEL_Str'Access, 127 FFO_Str'Access, 128 JVM_Str'Access, 129 MOV_Str'Access, 130 MRN_Str'Access, 131 PAS_Str'Access, 132 RTX_Str'Access, 133 SAG_Str'Access, 134 SAP_Str'Access, 135 SCA_Str'Access, 136 SCC_Str'Access, 137 SCD_Str'Access, 138 SCL_Str'Access, 139 SCP_Str'Access, 140 SLS_Str'Access, 141 SNZ_Str'Access, 142 SSL_Str'Access, 143 UAM_Str'Access, 144 VMS_Str'Access, 145 ZCD_Str'Access); 146 147 ----------------------- 148 -- Local Subprograms -- 149 ----------------------- 150 151 procedure Set_Profile_Restrictions (P : Profile_Name); 152 -- Set Restrictions_On_Target for the given profile 153 154 --------------------------- 155 -- Get_Target_Parameters -- 156 --------------------------- 157 158 -- Version which reads in system.ads 159 160 procedure Get_Target_Parameters is 161 Text : Source_Buffer_Ptr; 162 Hi : Source_Ptr; 163 164 begin 165 if Parameters_Obtained then 166 return; 167 end if; 168 169 Name_Buffer (1 .. 10) := "system.ads"; 170 Name_Len := 10; 171 172 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text); 173 174 if Text = null then 175 Write_Line ("fatal error, run-time library not installed correctly"); 176 Write_Line ("cannot locate file system.ads"); 177 raise Unrecoverable_Error; 178 end if; 179 180 Get_Target_Parameters 181 (System_Text => Text, 182 Source_First => 0, 183 Source_Last => Hi); 184 end Get_Target_Parameters; 185 186 -- Version where caller supplies system.ads text 187 188 procedure Get_Target_Parameters 189 (System_Text : Source_Buffer_Ptr; 190 Source_First : Source_Ptr; 191 Source_Last : Source_Ptr) 192 is 193 P : Source_Ptr; 194 -- Scans source buffer containing source of system.ads 195 196 Fatal : Boolean := False; 197 -- Set True if a fatal error is detected 198 199 Result : Boolean; 200 -- Records boolean from system line 201 202 begin 203 if Parameters_Obtained then 204 return; 205 else 206 Parameters_Obtained := True; 207 end if; 208 209 Opt.Address_Is_Private := False; 210 211 P := Source_First; 212 Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop 213 214 -- Skip comments quickly 215 216 if System_Text (P) = '-' then 217 goto Line_Loop_Continue; 218 219 -- Test for type Address is private 220 221 elsif System_Text (P .. P + 26) = " type Address is private;" then 222 Opt.Address_Is_Private := True; 223 P := P + 26; 224 goto Line_Loop_Continue; 225 226 -- Test for pragma Profile (Ravenscar); 227 228 elsif System_Text (P .. P + 26) = 229 "pragma Profile (Ravenscar);" 230 then 231 Set_Profile_Restrictions (Ravenscar); 232 Opt.Task_Dispatching_Policy := 'F'; 233 Opt.Locking_Policy := 'C'; 234 P := P + 27; 235 goto Line_Loop_Continue; 236 237 -- Test for pragma Profile (Restricted); 238 239 elsif System_Text (P .. P + 27) = 240 "pragma Profile (Restricted);" 241 then 242 Set_Profile_Restrictions (Restricted); 243 P := P + 28; 244 goto Line_Loop_Continue; 245 246 -- Test for pragma Restrictions 247 248 elsif System_Text (P .. P + 20) = "pragma Restrictions (" then 249 P := P + 21; 250 251 Rloop : for K in All_Boolean_Restrictions loop 252 declare 253 Rname : constant String := Restriction_Id'Image (K); 254 255 begin 256 for J in Rname'Range loop 257 if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) 258 /= Rname (J) 259 then 260 goto Rloop_Continue; 261 end if; 262 end loop; 263 264 if System_Text (P + Rname'Length) = ')' then 265 Restrictions_On_Target.Set (K) := True; 266 goto Line_Loop_Continue; 267 end if; 268 end; 269 270 <<Rloop_Continue>> 271 null; 272 end loop Rloop; 273 274 Ploop : for K in All_Parameter_Restrictions loop 275 declare 276 Rname : constant String := 277 All_Parameter_Restrictions'Image (K); 278 279 V : Natural; 280 -- Accumulates value 281 282 begin 283 for J in Rname'Range loop 284 if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) 285 /= Rname (J) 286 then 287 goto Ploop_Continue; 288 end if; 289 end loop; 290 291 if System_Text (P + Rname'Length .. P + Rname'Length + 3) = 292 " => " 293 then 294 P := P + Rname'Length + 4; 295 296 V := 0; 297 loop 298 if System_Text (P) in '0' .. '9' then 299 declare 300 pragma Unsuppress (Overflow_Check); 301 302 begin 303 -- Accumulate next digit 304 305 V := 10 * V + 306 Character'Pos (System_Text (P)) - 307 Character'Pos ('0'); 308 309 exception 310 -- On overflow, we just ignore the pragma since 311 -- that is the standard handling in this case. 312 313 when Constraint_Error => 314 goto Line_Loop_Continue; 315 end; 316 317 elsif System_Text (P) = '_' then 318 null; 319 320 elsif System_Text (P) = ')' then 321 Restrictions_On_Target.Value (K) := V; 322 Restrictions_On_Target.Set (K) := True; 323 goto Line_Loop_Continue; 324 325 else 326 exit Ploop; 327 end if; 328 329 P := P + 1; 330 end loop; 331 332 else 333 exit Ploop; 334 end if; 335 end; 336 337 <<Ploop_Continue>> 338 null; 339 end loop Ploop; 340 341 Set_Standard_Error; 342 Write_Line 343 ("fatal error: system.ads is incorrectly formatted"); 344 Write_Str ("unrecognized or incorrect restrictions pragma: "); 345 346 while System_Text (P) /= ')' 347 and then 348 System_Text (P) /= ASCII.LF 349 loop 350 Write_Char (System_Text (P)); 351 P := P + 1; 352 end loop; 353 354 Write_Eol; 355 Fatal := True; 356 Set_Standard_Output; 357 358 -- Test for pragma Detect_Blocking; 359 360 elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then 361 P := P + 23; 362 Opt.Detect_Blocking := True; 363 goto Line_Loop_Continue; 364 365 -- Discard_Names 366 367 elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then 368 P := P + 21; 369 Opt.Global_Discard_Names := True; 370 goto Line_Loop_Continue; 371 372 -- Locking Policy 373 374 elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then 375 P := P + 23; 376 Opt.Locking_Policy := System_Text (P); 377 Opt.Locking_Policy_Sloc := System_Location; 378 goto Line_Loop_Continue; 379 380 -- Normalize_Scalars 381 382 elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then 383 P := P + 25; 384 Opt.Normalize_Scalars := True; 385 Opt.Init_Or_Norm_Scalars := True; 386 goto Line_Loop_Continue; 387 388 -- Polling (On) 389 390 elsif System_Text (P .. P + 19) = "pragma Polling (On);" then 391 P := P + 20; 392 Opt.Polling_Required := True; 393 goto Line_Loop_Continue; 394 395 -- Ignore pragma Pure (System) 396 397 elsif System_Text (P .. P + 20) = "pragma Pure (System);" then 398 P := P + 21; 399 goto Line_Loop_Continue; 400 401 -- Queuing Policy 402 403 elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then 404 P := P + 23; 405 Opt.Queuing_Policy := System_Text (P); 406 Opt.Queuing_Policy_Sloc := System_Location; 407 goto Line_Loop_Continue; 408 409 -- Suppress_Exception_Locations 410 411 elsif System_Text (P .. P + 35) = 412 "pragma Suppress_Exception_Locations;" 413 then 414 P := P + 36; 415 Opt.Exception_Locations_Suppressed := True; 416 goto Line_Loop_Continue; 417 418 -- Task_Dispatching Policy 419 420 elsif System_Text (P .. P + 31) = 421 "pragma Task_Dispatching_Policy (" 422 then 423 P := P + 32; 424 Opt.Task_Dispatching_Policy := System_Text (P); 425 Opt.Task_Dispatching_Policy_Sloc := System_Location; 426 goto Line_Loop_Continue; 427 428 -- No other pragmas are permitted 429 430 elsif System_Text (P .. P + 6) = "pragma " then 431 Set_Standard_Error; 432 Write_Line ("unrecognized line in system.ads: "); 433 434 while System_Text (P) /= ')' 435 and then System_Text (P) /= ASCII.LF 436 loop 437 Write_Char (System_Text (P)); 438 P := P + 1; 439 end loop; 440 441 Write_Eol; 442 Set_Standard_Output; 443 Fatal := True; 444 445 -- See if we have a Run_Time_Name 446 447 elsif System_Text (P .. P + 38) = 448 " Run_Time_Name : constant String := """ 449 then 450 P := P + 39; 451 452 Name_Len := 0; 453 while System_Text (P) in 'A' .. 'Z' 454 or else 455 System_Text (P) in 'a' .. 'z' 456 or else 457 System_Text (P) in '0' .. '9' 458 or else 459 System_Text (P) = ' ' 460 or else 461 System_Text (P) = '_' 462 loop 463 Add_Char_To_Name_Buffer (System_Text (P)); 464 P := P + 1; 465 end loop; 466 467 if System_Text (P) /= '"' 468 or else System_Text (P + 1) /= ';' 469 or else (System_Text (P + 2) /= ASCII.LF 470 and then 471 System_Text (P + 2) /= ASCII.CR) 472 then 473 Set_Standard_Error; 474 Write_Line 475 ("incorrectly formatted Run_Time_Name in system.ads"); 476 Set_Standard_Output; 477 Fatal := True; 478 479 else 480 Run_Time_Name_On_Target := Name_Enter; 481 end if; 482 483 goto Line_Loop_Continue; 484 485 -- See if we have an Executable_Extension 486 487 elsif System_Text (P .. P + 45) = 488 " Executable_Extension : constant String := """ 489 then 490 P := P + 46; 491 492 Name_Len := 0; 493 while System_Text (P) /= '"' 494 and then System_Text (P) /= ASCII.LF 495 loop 496 Add_Char_To_Name_Buffer (System_Text (P)); 497 P := P + 1; 498 end loop; 499 500 if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then 501 Set_Standard_Error; 502 Write_Line 503 ("incorrectly formatted Executable_Extension in system.ads"); 504 Set_Standard_Output; 505 Fatal := True; 506 507 else 508 Executable_Extension_On_Target := Name_Enter; 509 end if; 510 511 goto Line_Loop_Continue; 512 513 -- Next see if we have a configuration parameter 514 515 else 516 Config_Param_Loop : for K in Targparm_Tags loop 517 if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) = 518 Targparm_Str (K).all 519 then 520 P := P + 3 + Targparm_Str (K)'Length; 521 522 if Targparm_Flags (K) then 523 Set_Standard_Error; 524 Write_Line 525 ("fatal error: system.ads is incorrectly formatted"); 526 Write_Str ("duplicate line for parameter: "); 527 528 for J in Targparm_Str (K)'Range loop 529 Write_Char (Targparm_Str (K).all (J)); 530 end loop; 531 532 Write_Eol; 533 Set_Standard_Output; 534 Fatal := True; 535 536 else 537 Targparm_Flags (K) := True; 538 end if; 539 540 while System_Text (P) /= ':' 541 or else System_Text (P + 1) /= '=' 542 loop 543 P := P + 1; 544 end loop; 545 546 P := P + 2; 547 548 while System_Text (P) = ' ' loop 549 P := P + 1; 550 end loop; 551 552 Result := (System_Text (P) = 'T'); 553 554 case K is 555 when AAM => AAMP_On_Target := Result; 556 when ACR => Always_Compatible_Rep_On_Target := Result; 557 when ASD => Atomic_Sync_Default_On_Target := Result; 558 when BDC => Backend_Divide_Checks_On_Target := Result; 559 when BOC => Backend_Overflow_Checks_On_Target := Result; 560 when CLA => Command_Line_Args_On_Target := Result; 561 when CLI => 562 if Result then 563 VM_Target := CLI_Target; 564 Tagged_Type_Expansion := False; 565 end if; 566 -- This is wrong, this processing should be done in 567 -- Gnat1drv.Adjust_Global_Switches. It is not the 568 -- right level for targparm to know about tagged 569 -- type extension??? 570 571 when CRT => Configurable_Run_Time_On_Target := Result; 572 when D32 => Duration_32_Bits_On_Target := Result; 573 when DEN => Denorm_On_Target := Result; 574 when EXS => Exit_Status_Supported_On_Target := Result; 575 when FEL => Frontend_Layout_On_Target := Result; 576 when FFO => Fractional_Fixed_Ops_On_Target := Result; 577 when JVM => 578 if Result then 579 VM_Target := JVM_Target; 580 Tagged_Type_Expansion := False; 581 end if; 582 -- This is wrong, this processing should be done in 583 -- Gnat1drv.Adjust_Global_Switches. It is not the 584 -- right level for targparm to know about tagged 585 -- type extension??? 586 587 when MOV => Machine_Overflows_On_Target := Result; 588 when MRN => Machine_Rounds_On_Target := Result; 589 when PAS => Preallocated_Stacks_On_Target := Result; 590 when RTX => RTX_RTSS_Kernel_Module_On_Target := Result; 591 when SAG => Support_Aggregates_On_Target := Result; 592 when SAP => Support_Atomic_Primitives_On_Target := Result; 593 when SCA => Support_Composite_Assign_On_Target := Result; 594 when SCC => Support_Composite_Compare_On_Target := Result; 595 when SCD => Stack_Check_Default_On_Target := Result; 596 when SCL => Stack_Check_Limits_On_Target := Result; 597 when SCP => Stack_Check_Probes_On_Target := Result; 598 when SLS => Support_Long_Shifts_On_Target := Result; 599 when SSL => Suppress_Standard_Library_On_Target := Result; 600 when SNZ => Signed_Zeros_On_Target := Result; 601 when UAM => Use_Ada_Main_Program_Name_On_Target := Result; 602 when VMS => OpenVMS_On_Target := Result; 603 when ZCD => ZCX_By_Default_On_Target := Result; 604 605 goto Line_Loop_Continue; 606 end case; 607 608 -- Here we are seeing a parameter we do not understand. We 609 -- simply ignore this (will happen when an old compiler is 610 -- used to compile a newer version of GNAT which does not 611 -- support the parameter). 612 end if; 613 end loop Config_Param_Loop; 614 end if; 615 616 -- Here after processing one line of System spec 617 618 <<Line_Loop_Continue>> 619 620 while System_Text (P) /= CR and then System_Text (P) /= LF loop 621 P := P + 1; 622 exit when P >= Source_Last; 623 end loop; 624 625 while System_Text (P) = CR or else System_Text (P) = LF loop 626 P := P + 1; 627 exit when P >= Source_Last; 628 end loop; 629 630 if P >= Source_Last then 631 Set_Standard_Error; 632 Write_Line ("fatal error, system.ads not formatted correctly"); 633 Write_Line ("unexpected end of file"); 634 Set_Standard_Output; 635 raise Unrecoverable_Error; 636 end if; 637 end loop Line_Loop; 638 639 -- Now that OpenVMS_On_Target has been given its definitive value, 640 -- change the multi-unit index character from '~' to '$' for OpenVMS. 641 642 if OpenVMS_On_Target then 643 Multi_Unit_Index_Character := '$'; 644 end if; 645 646 if Fatal then 647 raise Unrecoverable_Error; 648 end if; 649 end Get_Target_Parameters; 650 651 ------------------------------ 652 -- Set_Profile_Restrictions -- 653 ------------------------------ 654 655 procedure Set_Profile_Restrictions (P : Profile_Name) is 656 R : Restriction_Flags renames Profile_Info (P).Set; 657 V : Restriction_Values renames Profile_Info (P).Value; 658 begin 659 for J in R'Range loop 660 if R (J) then 661 Restrictions_On_Target.Set (J) := True; 662 663 if J in All_Parameter_Restrictions then 664 Restrictions_On_Target.Value (J) := V (J); 665 end if; 666 end if; 667 end loop; 668 end Set_Profile_Restrictions; 669 670end Targparm; 671