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-2015, 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 CRT, -- Configurable_Run_Times 48 D32, -- Duration_32_Bits 49 DEN, -- Denorm 50 EXS, -- Exit_Status_Supported 51 FEL, -- Frontend_Layout 52 FEX, -- Frontend_Exceptions 53 FFO, -- Fractional_Fixed_Ops 54 MOV, -- Machine_Overflows 55 MRN, -- Machine_Rounds 56 PAS, -- Preallocated_Stacks 57 SAG, -- Support_Aggregates 58 SAP, -- Support_Atomic_Primitives 59 SCA, -- Support_Composite_Assign 60 SCC, -- Support_Composite_Compare 61 SCD, -- Stack_Check_Default 62 SCL, -- Stack_Check_Limits 63 SCP, -- Stack_Check_Probes 64 SLS, -- Support_Long_Shifts 65 SNZ, -- Signed_Zeros 66 SSL, -- Suppress_Standard_Library 67 UAM, -- Use_Ada_Main_Program_Name 68 ZCX); -- ZCX_By_Default 69 70 Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); 71 -- Flag is set True if corresponding parameter is scanned 72 73 -- The following list of string constants gives the parameter names 74 75 AAM_Str : aliased constant Source_Buffer := "AAMP"; 76 ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep"; 77 ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default"; 78 BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; 79 BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; 80 CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; 81 CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; 82 D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; 83 DEN_Str : aliased constant Source_Buffer := "Denorm"; 84 EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported"; 85 FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; 86 FEX_Str : aliased constant Source_Buffer := "Frontend_Exceptions"; 87 FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; 88 MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; 89 MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; 90 PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; 91 SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; 92 SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives"; 93 SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; 94 SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare"; 95 SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default"; 96 SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits"; 97 SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes"; 98 SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts"; 99 SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros"; 100 SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library"; 101 UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; 102 ZCX_Str : aliased constant Source_Buffer := "ZCX_By_Default"; 103 104 -- The following defines a set of pointers to the above strings, 105 -- indexed by the tag values. 106 107 type Buffer_Ptr is access constant Source_Buffer; 108 Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr := 109 (AAM_Str'Access, 110 ACR_Str'Access, 111 ASD_Str'Access, 112 BDC_Str'Access, 113 BOC_Str'Access, 114 CLA_Str'Access, 115 CRT_Str'Access, 116 D32_Str'Access, 117 DEN_Str'Access, 118 EXS_Str'Access, 119 FEL_Str'Access, 120 FEX_Str'Access, 121 FFO_Str'Access, 122 MOV_Str'Access, 123 MRN_Str'Access, 124 PAS_Str'Access, 125 SAG_Str'Access, 126 SAP_Str'Access, 127 SCA_Str'Access, 128 SCC_Str'Access, 129 SCD_Str'Access, 130 SCL_Str'Access, 131 SCP_Str'Access, 132 SLS_Str'Access, 133 SNZ_Str'Access, 134 SSL_Str'Access, 135 UAM_Str'Access, 136 ZCX_Str'Access); 137 138 ----------------------- 139 -- Local Subprograms -- 140 ----------------------- 141 142 procedure Set_Profile_Restrictions (P : Profile_Name); 143 -- Set Restrictions_On_Target for the given profile 144 145 --------------------------- 146 -- Get_Target_Parameters -- 147 --------------------------- 148 149 -- Version which reads in system.ads 150 151 procedure Get_Target_Parameters 152 (Make_Id : Make_Id_Type := null; 153 Make_SC : Make_SC_Type := null; 154 Set_NOD : Set_NOD_Type := null; 155 Set_NSA : Set_NSA_Type := null; 156 Set_NUA : Set_NUA_Type := null; 157 Set_NUP : Set_NUP_Type := null) 158 is 159 Text : Source_Buffer_Ptr; 160 Hi : Source_Ptr; 161 162 begin 163 if Parameters_Obtained then 164 return; 165 end if; 166 167 Name_Buffer (1 .. 10) := "system.ads"; 168 Name_Len := 10; 169 170 Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text); 171 172 if Text = null then 173 Write_Line ("fatal error, run-time library not installed correctly"); 174 Write_Line ("cannot locate file system.ads"); 175 raise Unrecoverable_Error; 176 end if; 177 178 Get_Target_Parameters 179 (System_Text => Text, 180 Source_First => 0, 181 Source_Last => Hi, 182 Make_Id => Make_Id, 183 Make_SC => Make_SC, 184 Set_NOD => Set_NOD, 185 Set_NSA => Set_NSA, 186 Set_NUA => Set_NUA, 187 Set_NUP => Set_NUP); 188 end Get_Target_Parameters; 189 190 -- Version where caller supplies system.ads text 191 192 procedure Get_Target_Parameters 193 (System_Text : Source_Buffer_Ptr; 194 Source_First : Source_Ptr; 195 Source_Last : Source_Ptr; 196 Make_Id : Make_Id_Type := null; 197 Make_SC : Make_SC_Type := null; 198 Set_NOD : Set_NOD_Type := null; 199 Set_NSA : Set_NSA_Type := null; 200 Set_NUA : Set_NUA_Type := null; 201 Set_NUP : Set_NUP_Type := null) 202 is 203 P : Source_Ptr; 204 -- Scans source buffer containing source of system.ads 205 206 Fatal : Boolean := False; 207 -- Set True if a fatal error is detected 208 209 Result : Boolean; 210 -- Records boolean from system line 211 212 OK : Boolean; 213 -- Status result from Set_NUP/NSA/NUA call 214 215 PR_Start : Source_Ptr; 216 -- Pointer to ( following pragma Restrictions 217 218 procedure Collect_Name; 219 -- Scan a name starting at System_Text (P), and put Name in Name_Buffer, 220 -- with Name_Len being length, folded to lower case. On return, P points 221 -- just past the last character (which should be a right paren). 222 223 ------------------ 224 -- Collect_Name -- 225 ------------------ 226 227 procedure Collect_Name is 228 begin 229 Name_Len := 0; 230 loop 231 if System_Text (P) in 'a' .. 'z' 232 or else 233 System_Text (P) = '_' 234 or else 235 System_Text (P) in '0' .. '9' 236 then 237 Name_Buffer (Name_Len + 1) := System_Text (P); 238 239 elsif System_Text (P) in 'A' .. 'Z' then 240 Name_Buffer (Name_Len + 1) := 241 Character'Val (Character'Pos (System_Text (P)) + 32); 242 243 else 244 exit; 245 end if; 246 247 P := P + 1; 248 Name_Len := Name_Len + 1; 249 end loop; 250 end Collect_Name; 251 252 -- Start of processing for Get_Target_Parameters 253 254 begin 255 if Parameters_Obtained then 256 return; 257 else 258 Parameters_Obtained := True; 259 end if; 260 261 Opt.Address_Is_Private := False; 262 263 -- Loop through source lines 264 265 -- Note: in the case or pragmas, we are only interested in pragmas that 266 -- appear as configuration pragmas. These are left justified, so they 267 -- do not have three spaces at the start. Pragmas appearing within the 268 -- package (like Pure and No_Elaboration_Code_All) will have the three 269 -- spaces at the start and so will be ignored. 270 271 -- For a special exception, see processing for pragma Pure below 272 273 P := Source_First; 274 Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop 275 276 -- Skip comments quickly 277 278 if System_Text (P) = '-' then 279 goto Line_Loop_Continue; 280 281 -- Test for type Address is private 282 283 elsif System_Text (P .. P + 26) = " type Address is private;" then 284 Opt.Address_Is_Private := True; 285 P := P + 26; 286 goto Line_Loop_Continue; 287 288 -- Test for pragma Profile (Ravenscar); 289 290 elsif System_Text (P .. P + 26) = 291 "pragma Profile (Ravenscar);" 292 then 293 Set_Profile_Restrictions (Ravenscar); 294 Opt.Task_Dispatching_Policy := 'F'; 295 Opt.Locking_Policy := 'C'; 296 P := P + 27; 297 goto Line_Loop_Continue; 298 299 -- Test for pragma Profile (GNAT_Extended_Ravenscar); 300 301 elsif System_Text (P .. P + 40) = 302 "pragma Profile (GNAT_Extended_Ravenscar);" 303 then 304 Set_Profile_Restrictions (GNAT_Extended_Ravenscar); 305 Opt.Task_Dispatching_Policy := 'F'; 306 Opt.Locking_Policy := 'C'; 307 P := P + 27; 308 goto Line_Loop_Continue; 309 310 -- Test for pragma Profile (Restricted); 311 312 elsif System_Text (P .. P + 27) = 313 "pragma Profile (Restricted);" 314 then 315 Set_Profile_Restrictions (Restricted); 316 P := P + 28; 317 goto Line_Loop_Continue; 318 319 -- Test for pragma Restrictions 320 321 elsif System_Text (P .. P + 20) = "pragma Restrictions (" then 322 P := P + 21; 323 PR_Start := P - 1; 324 325 -- Boolean restrictions 326 327 Rloop : for K in All_Boolean_Restrictions loop 328 declare 329 Rname : constant String := Restriction_Id'Image (K); 330 331 begin 332 for J in Rname'Range loop 333 if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) 334 /= Rname (J) 335 then 336 goto Rloop_Continue; 337 end if; 338 end loop; 339 340 if System_Text (P + Rname'Length) = ')' then 341 Restrictions_On_Target.Set (K) := True; 342 goto Line_Loop_Continue; 343 end if; 344 end; 345 346 <<Rloop_Continue>> 347 null; 348 end loop Rloop; 349 350 -- Restrictions taking integer parameter 351 352 Ploop : for K in Integer_Parameter_Restrictions loop 353 declare 354 Rname : constant String := 355 All_Parameter_Restrictions'Image (K); 356 357 V : Natural; 358 -- Accumulates value 359 360 begin 361 for J in Rname'Range loop 362 if Fold_Upper (System_Text (P + Source_Ptr (J - 1))) 363 /= Rname (J) 364 then 365 goto Ploop_Continue; 366 end if; 367 end loop; 368 369 if System_Text (P + Rname'Length .. P + Rname'Length + 3) = 370 " => " 371 then 372 P := P + Rname'Length + 4; 373 374 V := 0; 375 loop 376 if System_Text (P) in '0' .. '9' then 377 declare 378 pragma Unsuppress (Overflow_Check); 379 380 begin 381 -- Accumulate next digit 382 383 V := 10 * V + 384 Character'Pos (System_Text (P)) - 385 Character'Pos ('0'); 386 387 exception 388 -- On overflow, we just ignore the pragma since 389 -- that is the standard handling in this case. 390 391 when Constraint_Error => 392 goto Line_Loop_Continue; 393 end; 394 395 elsif System_Text (P) = '_' then 396 null; 397 398 elsif System_Text (P) = ')' then 399 Restrictions_On_Target.Value (K) := V; 400 Restrictions_On_Target.Set (K) := True; 401 goto Line_Loop_Continue; 402 403 else 404 exit Ploop; 405 end if; 406 407 P := P + 1; 408 end loop; 409 410 else 411 exit Ploop; 412 end if; 413 end; 414 415 <<Ploop_Continue>> 416 null; 417 end loop Ploop; 418 419 -- No_Dependence case 420 421 if System_Text (P .. P + 16) = "No_Dependence => " then 422 P := P + 17; 423 424 -- Skip this processing (and simply ignore No_Dependence lines) 425 -- if caller did not supply the three subprograms we need to 426 -- process these lines. 427 428 if Make_Id = null then 429 goto Line_Loop_Continue; 430 end if; 431 432 -- We have scanned out "pragma Restrictions (No_Dependence =>" 433 434 declare 435 Unit : Node_Id; 436 Id : Node_Id; 437 Start : Source_Ptr; 438 439 begin 440 Unit := Empty; 441 442 -- Loop through components of name, building up Unit 443 444 loop 445 Start := P; 446 while System_Text (P) /= '.' 447 and then 448 System_Text (P) /= ')' 449 loop 450 P := P + 1; 451 end loop; 452 453 Id := Make_Id (System_Text (Start .. P - 1)); 454 455 -- If first name, just capture the identifier 456 457 if Unit = Empty then 458 Unit := Id; 459 else 460 Unit := Make_SC (Unit, Id); 461 end if; 462 463 exit when System_Text (P) = ')'; 464 P := P + 1; 465 end loop; 466 467 Set_NOD (Unit); 468 goto Line_Loop_Continue; 469 end; 470 471 -- No_Specification_Of_Aspect case 472 473 elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => " 474 then 475 P := P + 30; 476 477 -- Skip this processing (and simply ignore the pragma), if 478 -- caller did not supply the subprogram we need to process 479 -- such lines. 480 481 if Set_NSA = null then 482 goto Line_Loop_Continue; 483 end if; 484 485 -- We have scanned 486 -- "pragma Restrictions (No_Specification_Of_Aspect =>" 487 488 Collect_Name; 489 490 if System_Text (P) /= ')' then 491 goto Bad_Restrictions_Pragma; 492 493 else 494 Set_NSA (Name_Find, OK); 495 496 if OK then 497 goto Line_Loop_Continue; 498 else 499 goto Bad_Restrictions_Pragma; 500 end if; 501 end if; 502 503 -- No_Use_Of_Attribute case 504 505 elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then 506 P := P + 23; 507 508 -- Skip this processing (and simply ignore No_Use_Of_Attribute 509 -- lines) if caller did not supply the subprogram we need to 510 -- process such lines. 511 512 if Set_NUA = null then 513 goto Line_Loop_Continue; 514 end if; 515 516 -- We have scanned 517 -- "pragma Restrictions (No_Use_Of_Attribute =>" 518 519 Collect_Name; 520 521 if System_Text (P) /= ')' then 522 goto Bad_Restrictions_Pragma; 523 524 else 525 Set_NUA (Name_Find, OK); 526 527 if OK then 528 goto Line_Loop_Continue; 529 else 530 goto Bad_Restrictions_Pragma; 531 end if; 532 end if; 533 534 -- No_Use_Of_Pragma case 535 536 elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then 537 P := P + 20; 538 539 -- Skip this processing (and simply ignore No_Use_Of_Pragma 540 -- lines) if caller did not supply the subprogram we need to 541 -- process such lines. 542 543 if Set_NUP = null then 544 goto Line_Loop_Continue; 545 end if; 546 547 -- We have scanned 548 -- "pragma Restrictions (No_Use_Of_Pragma =>" 549 550 Collect_Name; 551 552 if System_Text (P) /= ')' then 553 goto Bad_Restrictions_Pragma; 554 555 else 556 Set_NUP (Name_Find, OK); 557 558 if OK then 559 goto Line_Loop_Continue; 560 else 561 goto Bad_Restrictions_Pragma; 562 end if; 563 end if; 564 end if; 565 566 -- Here if unrecognizable restrictions pragma form 567 568 <<Bad_Restrictions_Pragma>> 569 570 Set_Standard_Error; 571 Write_Line 572 ("fatal error: system.ads is incorrectly formatted"); 573 Write_Str ("unrecognized or incorrect restrictions pragma: "); 574 575 P := PR_Start; 576 loop 577 exit when System_Text (P) = ASCII.LF; 578 Write_Char (System_Text (P)); 579 exit when System_Text (P) = ')'; 580 P := P + 1; 581 end loop; 582 583 Write_Eol; 584 Fatal := True; 585 Set_Standard_Output; 586 587 -- Test for pragma Detect_Blocking; 588 589 elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then 590 P := P + 23; 591 Opt.Detect_Blocking := True; 592 goto Line_Loop_Continue; 593 594 -- Discard_Names 595 596 elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then 597 P := P + 21; 598 Opt.Global_Discard_Names := True; 599 goto Line_Loop_Continue; 600 601 -- Locking Policy 602 603 elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then 604 P := P + 23; 605 Opt.Locking_Policy := System_Text (P); 606 Opt.Locking_Policy_Sloc := System_Location; 607 goto Line_Loop_Continue; 608 609 -- Normalize_Scalars 610 611 elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then 612 P := P + 25; 613 Opt.Normalize_Scalars := True; 614 Opt.Init_Or_Norm_Scalars := True; 615 goto Line_Loop_Continue; 616 617 -- Partition_Elaboration_Policy 618 619 elsif System_Text (P .. P + 36) = 620 "pragma Partition_Elaboration_Policy (" 621 then 622 P := P + 37; 623 Opt.Partition_Elaboration_Policy := System_Text (P); 624 Opt.Partition_Elaboration_Policy_Sloc := System_Location; 625 goto Line_Loop_Continue; 626 627 -- Polling (On) 628 629 elsif System_Text (P .. P + 19) = "pragma Polling (On);" then 630 P := P + 20; 631 Opt.Polling_Required := True; 632 goto Line_Loop_Continue; 633 634 -- Queuing Policy 635 636 elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then 637 P := P + 23; 638 Opt.Queuing_Policy := System_Text (P); 639 Opt.Queuing_Policy_Sloc := System_Location; 640 goto Line_Loop_Continue; 641 642 -- Suppress_Exception_Locations 643 644 elsif System_Text (P .. P + 35) = 645 "pragma Suppress_Exception_Locations;" 646 then 647 P := P + 36; 648 Opt.Exception_Locations_Suppressed := True; 649 goto Line_Loop_Continue; 650 651 -- Task_Dispatching Policy 652 653 elsif System_Text (P .. P + 31) = 654 "pragma Task_Dispatching_Policy (" 655 then 656 P := P + 32; 657 Opt.Task_Dispatching_Policy := System_Text (P); 658 Opt.Task_Dispatching_Policy_Sloc := System_Location; 659 goto Line_Loop_Continue; 660 661 -- No other configuration pragmas are permitted 662 663 elsif System_Text (P .. P + 6) = "pragma " then 664 665 -- Special exception, we allow pragma Pure (System) appearing in 666 -- column one. This is an obsolete usage which may show up in old 667 -- tests with an obsolete version of system.ads, so we recognize 668 -- and ignore it to make life easier in handling such tests. 669 670 if System_Text (P .. P + 20) = "pragma Pure (System);" then 671 P := P + 21; 672 goto Line_Loop_Continue; 673 end if; 674 675 Set_Standard_Error; 676 Write_Line ("unrecognized line in system.ads: "); 677 678 while System_Text (P) /= ')' 679 and then System_Text (P) /= ASCII.LF 680 loop 681 Write_Char (System_Text (P)); 682 P := P + 1; 683 end loop; 684 685 Write_Eol; 686 Set_Standard_Output; 687 Fatal := True; 688 689 -- See if we have a Run_Time_Name 690 691 elsif System_Text (P .. P + 38) = 692 " Run_Time_Name : constant String := """ 693 then 694 P := P + 39; 695 696 Name_Len := 0; 697 while System_Text (P) in 'A' .. 'Z' 698 or else 699 System_Text (P) in 'a' .. 'z' 700 or else 701 System_Text (P) in '0' .. '9' 702 or else 703 System_Text (P) = ' ' 704 or else 705 System_Text (P) = '_' 706 loop 707 Add_Char_To_Name_Buffer (System_Text (P)); 708 P := P + 1; 709 end loop; 710 711 if System_Text (P) /= '"' 712 or else System_Text (P + 1) /= ';' 713 or else (System_Text (P + 2) /= ASCII.LF 714 and then 715 System_Text (P + 2) /= ASCII.CR) 716 then 717 Set_Standard_Error; 718 Write_Line 719 ("incorrectly formatted Run_Time_Name in system.ads"); 720 Set_Standard_Output; 721 Fatal := True; 722 723 else 724 Run_Time_Name_On_Target := Name_Enter; 725 end if; 726 727 goto Line_Loop_Continue; 728 729 -- See if we have an Executable_Extension 730 731 elsif System_Text (P .. P + 45) = 732 " Executable_Extension : constant String := """ 733 then 734 P := P + 46; 735 736 Name_Len := 0; 737 while System_Text (P) /= '"' 738 and then System_Text (P) /= ASCII.LF 739 loop 740 Add_Char_To_Name_Buffer (System_Text (P)); 741 P := P + 1; 742 end loop; 743 744 if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then 745 Set_Standard_Error; 746 Write_Line 747 ("incorrectly formatted Executable_Extension in system.ads"); 748 Set_Standard_Output; 749 Fatal := True; 750 751 else 752 Executable_Extension_On_Target := Name_Enter; 753 end if; 754 755 goto Line_Loop_Continue; 756 757 -- Next see if we have a configuration parameter 758 759 else 760 Config_Param_Loop : for K in Targparm_Tags loop 761 if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) = 762 Targparm_Str (K).all 763 then 764 P := P + 3 + Targparm_Str (K)'Length; 765 766 if Targparm_Flags (K) then 767 Set_Standard_Error; 768 Write_Line 769 ("fatal error: system.ads is incorrectly formatted"); 770 Write_Str ("duplicate line for parameter: "); 771 772 for J in Targparm_Str (K)'Range loop 773 Write_Char (Targparm_Str (K).all (J)); 774 end loop; 775 776 Write_Eol; 777 Set_Standard_Output; 778 Fatal := True; 779 780 else 781 Targparm_Flags (K) := True; 782 end if; 783 784 while System_Text (P) /= ':' 785 or else System_Text (P + 1) /= '=' 786 loop 787 P := P + 1; 788 end loop; 789 790 P := P + 2; 791 792 while System_Text (P) = ' ' loop 793 P := P + 1; 794 end loop; 795 796 Result := (System_Text (P) = 'T'); 797 798 case K is 799 when AAM => AAMP_On_Target := Result; 800 when ACR => Always_Compatible_Rep_On_Target := Result; 801 when ASD => Atomic_Sync_Default_On_Target := Result; 802 when BDC => Backend_Divide_Checks_On_Target := Result; 803 when BOC => Backend_Overflow_Checks_On_Target := Result; 804 when CLA => Command_Line_Args_On_Target := Result; 805 when CRT => Configurable_Run_Time_On_Target := Result; 806 when D32 => Duration_32_Bits_On_Target := Result; 807 when DEN => Denorm_On_Target := Result; 808 when EXS => Exit_Status_Supported_On_Target := Result; 809 when FEL => Frontend_Layout_On_Target := Result; 810 when FEX => Frontend_Exceptions_On_Target := Result; 811 when FFO => Fractional_Fixed_Ops_On_Target := Result; 812 when MOV => Machine_Overflows_On_Target := Result; 813 when MRN => Machine_Rounds_On_Target := Result; 814 when PAS => Preallocated_Stacks_On_Target := Result; 815 when SAG => Support_Aggregates_On_Target := Result; 816 when SAP => Support_Atomic_Primitives_On_Target := Result; 817 when SCA => Support_Composite_Assign_On_Target := Result; 818 when SCC => Support_Composite_Compare_On_Target := Result; 819 when SCD => Stack_Check_Default_On_Target := Result; 820 when SCL => Stack_Check_Limits_On_Target := Result; 821 when SCP => Stack_Check_Probes_On_Target := Result; 822 when SLS => Support_Long_Shifts_On_Target := Result; 823 when SSL => Suppress_Standard_Library_On_Target := Result; 824 when SNZ => Signed_Zeros_On_Target := Result; 825 when UAM => Use_Ada_Main_Program_Name_On_Target := Result; 826 when ZCX => ZCX_By_Default_On_Target := Result; 827 828 goto Line_Loop_Continue; 829 end case; 830 831 -- Here we are seeing a parameter we do not understand. We 832 -- simply ignore this (will happen when an old compiler is 833 -- used to compile a newer version of GNAT which does not 834 -- support the parameter). 835 end if; 836 end loop Config_Param_Loop; 837 end if; 838 839 -- Here after processing one line of System spec 840 841 <<Line_Loop_Continue>> 842 843 while System_Text (P) /= CR and then System_Text (P) /= LF loop 844 P := P + 1; 845 exit when P >= Source_Last; 846 end loop; 847 848 while System_Text (P) = CR or else System_Text (P) = LF loop 849 P := P + 1; 850 exit when P >= Source_Last; 851 end loop; 852 853 if P >= Source_Last then 854 Set_Standard_Error; 855 Write_Line ("fatal error, system.ads not formatted correctly"); 856 Write_Line ("unexpected end of file"); 857 Set_Standard_Output; 858 raise Unrecoverable_Error; 859 end if; 860 end loop Line_Loop; 861 862 if Fatal then 863 raise Unrecoverable_Error; 864 end if; 865 end Get_Target_Parameters; 866 867 ------------------------------ 868 -- Set_Profile_Restrictions -- 869 ------------------------------ 870 871 procedure Set_Profile_Restrictions (P : Profile_Name) is 872 R : Restriction_Flags renames Profile_Info (P).Set; 873 V : Restriction_Values renames Profile_Info (P).Value; 874 begin 875 for J in R'Range loop 876 if R (J) then 877 Restrictions_On_Target.Set (J) := True; 878 879 if J in All_Parameter_Restrictions then 880 Restrictions_On_Target.Value (J) := V (J); 881 end if; 882 end if; 883 end loop; 884 end Set_Profile_Restrictions; 885 886end Targparm; 887