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