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