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