gcc/ada/targparm.adb

   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
  26 with Csets;         use Csets;
  27 with Opt;
  28 with Osint;         use Osint;
  29 with Output;        use Output;
  30 with System.OS_Lib; use System.OS_Lib;
  31
  32 package 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 (Jorvik);
 338
 339          elsif Looking_At_Skip ("pragma Profile (Jorvik);") then
 340             Set_Profile_Restrictions (Jorvik);
 341             Opt.Task_Dispatching_Policy := 'F';
 342             Opt.Locking_Policy          := 'C';
 343             goto Line_Loop_Continue;
 344
 345          --  Test for pragma Profile (GNAT_Extended_Ravenscar);
 346
 347          elsif Looking_At_Skip
 348            ("pragma Profile (GNAT_Extended_Ravenscar);")
 349          then
 350             Set_Profile_Restrictions (GNAT_Extended_Ravenscar);
 351             Opt.Task_Dispatching_Policy := 'F';
 352             Opt.Locking_Policy          := 'C';
 353             goto Line_Loop_Continue;
 354
 355          --  Test for pragma Profile (GNAT_Ravenscar_EDF);
 356
 357          elsif Looking_At_Skip ("pragma Profile (GNAT_Ravenscar_EDF);") then
 358             Set_Profile_Restrictions (GNAT_Ravenscar_EDF);
 359             Opt.Task_Dispatching_Policy := 'E';
 360             Opt.Locking_Policy          := 'C';
 361             goto Line_Loop_Continue;
 362
 363          --  Test for pragma Profile (Restricted);
 364
 365          elsif Looking_At_Skip ("pragma Profile (Restricted);") then
 366             Set_Profile_Restrictions (Restricted);
 367             goto Line_Loop_Continue;
 368
 369          --  Test for pragma Restrictions
 370
 371          elsif Looking_At_Skip ("pragma Restrictions (") then
 372             PR_Start := P - 1;
 373
 374             --  Boolean restrictions
 375
 376             for K in All_Boolean_Restrictions loop
 377                declare
 378                   Rname : constant String := Restriction_Id'Image (K);
 379
 380                begin
 381                   for J in Rname'Range loop
 382                      if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
 383                                                         /= Rname (J)
 384                      then
 385                         goto Rloop_Continue;
 386                      end if;
 387                   end loop;
 388
 389                   if System_Text (P + Rname'Length) = ')' then
 390                      Restrictions_On_Target.Set (K) := True;
 391                      goto Line_Loop_Continue;
 392                   end if;
 393                end;
 394
 395                <<Rloop_Continue>> null;
 396             end loop;
 397
 398             --  Restrictions taking integer parameter
 399
 400             Ploop : for K in Integer_Parameter_Restrictions loop
 401                declare
 402                   Rname : constant String :=
 403                             All_Parameter_Restrictions'Image (K);
 404
 405                   V : Natural;
 406                   --  Accumulates value
 407
 408                begin
 409                   for J in Rname'Range loop
 410                      if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
 411                                                         /= Rname (J)
 412                      then
 413                         goto Ploop_Continue;
 414                      end if;
 415                   end loop;
 416
 417                   if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
 418                                                       " => "
 419                   then
 420                      P := P + Rname'Length + 4;
 421
 422                      V := 0;
 423                      loop
 424                         if System_Text (P) in '0' .. '9' then
 425                            declare
 426                               pragma Unsuppress (Overflow_Check);
 427
 428                            begin
 429                               --  Accumulate next digit
 430
 431                               V := 10 * V +
 432                                    Character'Pos (System_Text (P)) -
 433                                    Character'Pos ('0');
 434
 435                            exception
 436                               --  On overflow, we just ignore the pragma since
 437                               --  that is the standard handling in this case.
 438
 439                               when Constraint_Error =>
 440                                  goto Line_Loop_Continue;
 441                            end;
 442
 443                         elsif System_Text (P) = '_' then
 444                            null;
 445
 446                         elsif System_Text (P) = ')' then
 447                            Restrictions_On_Target.Value (K) := V;
 448                            Restrictions_On_Target.Set (K) := True;
 449                            goto Line_Loop_Continue;
 450
 451                         else
 452                            exit Ploop;
 453                         end if;
 454
 455                         P := P + 1;
 456                      end loop;
 457
 458                   else
 459                      exit Ploop;
 460                   end if;
 461                end;
 462
 463                <<Ploop_Continue>> null;
 464             end loop Ploop;
 465
 466             --  No_Dependence case
 467
 468             if Looking_At_Skip ("No_Dependence => ") then
 469                --  Skip this processing (and simply ignore No_Dependence lines)
 470                --  if caller did not supply the three subprograms we need to
 471                --  process these lines.
 472
 473                if Make_Id = null then
 474                   goto Line_Loop_Continue;
 475                end if;
 476
 477                --  We have scanned out "pragma Restrictions (No_Dependence =>"
 478
 479                declare
 480                   Unit  : Node_Id;
 481                   Id    : Node_Id;
 482                   Start : Source_Ptr;
 483
 484                begin
 485                   Unit := Empty;
 486
 487                   --  Loop through components of name, building up Unit
 488
 489                   loop
 490                      Start := P;
 491                      while System_Text (P) /= '.'
 492                              and then
 493                            System_Text (P) /= ')'
 494                      loop
 495                         P := P + 1;
 496                      end loop;
 497
 498                      Id := Make_Id (System_Text (Start .. P - 1));
 499
 500                      --  If first name, just capture the identifier
 501
 502                      if Unit = Empty then
 503                         Unit := Id;
 504                      else
 505                         Unit := Make_SC (Unit, Id);
 506                      end if;
 507
 508                      exit when System_Text (P) = ')';
 509                      P := P + 1;
 510                   end loop;
 511
 512                   Set_NOD (Unit);
 513                   goto Line_Loop_Continue;
 514                end;
 515
 516             --  No_Specification_Of_Aspect case
 517
 518             elsif Looking_At_Skip ("No_Specification_Of_Aspect => ") then
 519                --  Skip this processing (and simply ignore the pragma), if
 520                --  caller did not supply the subprogram we need to process
 521                --  such lines.
 522
 523                if Set_NSA = null then
 524                   goto Line_Loop_Continue;
 525                end if;
 526
 527                --  We have scanned
 528                --    "pragma Restrictions (No_Specification_Of_Aspect =>"
 529
 530                Collect_Name;
 531
 532                if System_Text (P) /= ')' then
 533                   goto Bad_Restrictions_Pragma;
 534
 535                else
 536                   Set_NSA (Name_Find, OK);
 537
 538                   if OK then
 539                      goto Line_Loop_Continue;
 540                   else
 541                      goto Bad_Restrictions_Pragma;
 542                   end if;
 543                end if;
 544
 545             --  No_Use_Of_Attribute case
 546
 547             elsif Looking_At_Skip ("No_Use_Of_Attribute => ") then
 548                --  Skip this processing (and simply ignore No_Use_Of_Attribute
 549                --  lines) if caller did not supply the subprogram we need to
 550                --  process such lines.
 551
 552                if Set_NUA = null then
 553                   goto Line_Loop_Continue;
 554                end if;
 555
 556                --  We have scanned
 557                --    "pragma Restrictions (No_Use_Of_Attribute =>"
 558
 559                Collect_Name;
 560
 561                if System_Text (P) /= ')' then
 562                   goto Bad_Restrictions_Pragma;
 563
 564                else
 565                   Set_NUA (Name_Find, OK);
 566
 567                   if OK then
 568                      goto Line_Loop_Continue;
 569                   else
 570                      goto Bad_Restrictions_Pragma;
 571                   end if;
 572                end if;
 573
 574             --  No_Use_Of_Pragma case
 575
 576             elsif Looking_At_Skip ("No_Use_Of_Pragma => ") then
 577                --  Skip this processing (and simply ignore No_Use_Of_Pragma
 578                --  lines) if caller did not supply the subprogram we need to
 579                --  process such lines.
 580
 581                if Set_NUP = null then
 582                   goto Line_Loop_Continue;
 583                end if;
 584
 585                --  We have scanned
 586                --    "pragma Restrictions (No_Use_Of_Pragma =>"
 587
 588                Collect_Name;
 589
 590                if System_Text (P) /= ')' then
 591                   goto Bad_Restrictions_Pragma;
 592
 593                else
 594                   Set_NUP (Name_Find, OK);
 595
 596                   if OK then
 597                      goto Line_Loop_Continue;
 598                   else
 599                      goto Bad_Restrictions_Pragma;
 600                   end if;
 601                end if;
 602             end if;
 603
 604             --  Here if unrecognizable restrictions pragma form
 605
 606             <<Bad_Restrictions_Pragma>>
 607
 608             Set_Standard_Error;
 609             Write_Line
 610                ("fatal error: system.ads is incorrectly formatted");
 611             Write_Str ("unrecognized or incorrect restrictions pragma: ");
 612
 613             P := PR_Start;
 614             loop
 615                exit when System_Text (P) = ASCII.LF;
 616                Write_Char (System_Text (P));
 617                exit when System_Text (P) = ')';
 618                P := P + 1;
 619             end loop;
 620
 621             Write_Eol;
 622             Fatal := True;
 623             Set_Standard_Output;
 624
 625          --  Test for pragma Detect_Blocking;
 626
 627          elsif Looking_At_Skip ("pragma Detect_Blocking;") then
 628             Opt.Detect_Blocking := True;
 629             goto Line_Loop_Continue;
 630
 631          --  Discard_Names
 632
 633          elsif Looking_At_Skip ("pragma Discard_Names;") then
 634             Opt.Global_Discard_Names := True;
 635             goto Line_Loop_Continue;
 636
 637          --  Locking Policy
 638
 639          elsif Looking_At_Skip ("pragma Locking_Policy (") then
 640             Opt.Locking_Policy := System_Text (P);
 641             Opt.Locking_Policy_Sloc := System_Location;
 642             goto Line_Loop_Continue;
 643
 644          --  Normalize_Scalars
 645
 646          elsif Looking_At_Skip ("pragma Normalize_Scalars;") then
 647             Opt.Normalize_Scalars := True;
 648             Opt.Init_Or_Norm_Scalars := True;
 649             goto Line_Loop_Continue;
 650
 651          --  Partition_Elaboration_Policy
 652
 653          elsif Looking_At_Skip ("pragma Partition_Elaboration_Policy (") then
 654             Opt.Partition_Elaboration_Policy := System_Text (P);
 655             Opt.Partition_Elaboration_Policy_Sloc := System_Location;
 656             goto Line_Loop_Continue;
 657
 658          --  Queuing Policy
 659
 660          elsif Looking_At_Skip ("pragma Queuing_Policy (") then
 661             Opt.Queuing_Policy := System_Text (P);
 662             Opt.Queuing_Policy_Sloc := System_Location;
 663             goto Line_Loop_Continue;
 664
 665          --  Suppress_Exception_Locations
 666
 667          elsif Looking_At_Skip ("pragma Suppress_Exception_Locations;") then
 668             Opt.Exception_Locations_Suppressed := True;
 669             goto Line_Loop_Continue;
 670
 671          --  Task_Dispatching Policy
 672
 673          elsif Looking_At_Skip ("pragma Task_Dispatching_Policy (") then
 674             Opt.Task_Dispatching_Policy := System_Text (P);
 675             Opt.Task_Dispatching_Policy_Sloc := System_Location;
 676             goto Line_Loop_Continue;
 677
 678          --  No other configuration pragmas are permitted
 679
 680          elsif Looking_At ("pragma ") then
 681             --  Special exception, we allow pragma Pure (System) appearing in
 682             --  column one. This is an obsolete usage which may show up in old
 683             --  tests with an obsolete version of system.ads, so we recognize
 684             --  and ignore it to make life easier in handling such tests.
 685
 686             if Looking_At_Skip ("pragma Pure (System);") then
 687                goto Line_Loop_Continue;
 688             end if;
 689
 690             Set_Standard_Error;
 691             Write_Line ("unrecognized line in system.ads: ");
 692
 693             while System_Text (P) /= ')'
 694               and then System_Text (P) /= ASCII.LF
 695             loop
 696                Write_Char (System_Text (P));
 697                P := P + 1;
 698             end loop;
 699
 700             Write_Eol;
 701             Set_Standard_Output;
 702             Fatal := True;
 703
 704          --  See if we have a Run_Time_Name
 705
 706          elsif Looking_At_Skip
 707            ("   Run_Time_Name : constant String := """)
 708          then
 709             Name_Len := 0;
 710             while System_Text (P) in 'A' .. 'Z'
 711                     or else
 712                   System_Text (P) in 'a' .. 'z'
 713                     or else
 714                   System_Text (P) in '0' .. '9'
 715                     or else
 716                   System_Text (P) = ' '
 717                     or else
 718                   System_Text (P) = '_'
 719             loop
 720                Add_Char_To_Name_Buffer (System_Text (P));
 721                P := P + 1;
 722             end loop;
 723
 724             if System_Text (P) /= '"'
 725               or else System_Text (P + 1) /= ';'
 726               or else (System_Text (P + 2) /= ASCII.LF
 727                          and then
 728                        System_Text (P + 2) /= ASCII.CR)
 729             then
 730                Set_Standard_Error;
 731                Write_Line
 732                  ("incorrectly formatted Run_Time_Name in system.ads");
 733                Set_Standard_Output;
 734                Fatal := True;
 735
 736             else
 737                Run_Time_Name_On_Target := Name_Enter;
 738             end if;
 739
 740             goto Line_Loop_Continue;
 741
 742          --  See if we have an Executable_Extension
 743
 744          elsif Looking_At_Skip
 745            ("   Executable_Extension : constant String := """)
 746          then
 747             Name_Len := 0;
 748             while System_Text (P) /= '"'
 749               and then System_Text (P) /= ASCII.LF
 750             loop
 751                Add_Char_To_Name_Buffer (System_Text (P));
 752                P := P + 1;
 753             end loop;
 754
 755             if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then
 756                Set_Standard_Error;
 757                Write_Line
 758                  ("incorrectly formatted Executable_Extension in system.ads");
 759                Set_Standard_Output;
 760                Fatal := True;
 761
 762             else
 763                Executable_Extension_On_Target := Name_Enter;
 764             end if;
 765
 766             goto Line_Loop_Continue;
 767
 768          --  Next see if we have a configuration parameter
 769
 770          else
 771             Config_Param_Loop : for K in Targparm_Tags loop
 772                if Looking_At_Skip ("   " & Targparm_Str (K).all) then
 773                   if Targparm_Flags (K) then
 774                      Set_Standard_Error;
 775                      Write_Line
 776                        ("fatal error: system.ads is incorrectly formatted");
 777                      Write_Str ("duplicate line for parameter: ");
 778
 779                      for J in Targparm_Str (K)'Range loop
 780                         Write_Char (Targparm_Str (K).all (J));
 781                      end loop;
 782
 783                      Write_Eol;
 784                      Set_Standard_Output;
 785                      Fatal := True;
 786
 787                   else
 788                      Targparm_Flags (K) := True;
 789                   end if;
 790
 791                   while System_Text (P) /= ':'
 792                      or else System_Text (P + 1) /= '='
 793                   loop
 794                      P := P + 1;
 795                   end loop;
 796
 797                   P := P + 2;
 798
 799                   while System_Text (P) = ' ' loop
 800                      P := P + 1;
 801                   end loop;
 802
 803                   Result := (System_Text (P) = 'T');
 804
 805                   case K is
 806                      when AAM => null;
 807                      when ACR => Always_Compatible_Rep_On_Target     := Result;
 808                      when ASD => Atomic_Sync_Default_On_Target       := Result;
 809                      when BDC => Backend_Divide_Checks_On_Target     := Result;
 810                      when BOC => Backend_Overflow_Checks_On_Target   := Result;
 811                      when CLA => Command_Line_Args_On_Target         := Result;
 812                      when CRT => Configurable_Run_Time_On_Target     := Result;
 813                      when D32 => Duration_32_Bits_On_Target          := Result;
 814                      when DEN => Denorm_On_Target                    := Result;
 815                      when EXS => Exit_Status_Supported_On_Target     := Result;
 816                      when FEL => null;
 817                      when FEX => Frontend_Exceptions_On_Target       := Result;
 818                      when FFO => Fractional_Fixed_Ops_On_Target      := Result;
 819                      when MOV => Machine_Overflows_On_Target         := Result;
 820                      when MRN => Machine_Rounds_On_Target            := Result;
 821                      when PAS => Preallocated_Stacks_On_Target       := Result;
 822                      when SAG => Support_Aggregates_On_Target        := Result;
 823                      when SAP => Support_Atomic_Primitives_On_Target := Result;
 824                      when SCA => Support_Composite_Assign_On_Target  := Result;
 825                      when SCC => Support_Composite_Compare_On_Target := Result;
 826                      when SCD => Stack_Check_Default_On_Target       := Result;
 827                      when SCL => Stack_Check_Limits_On_Target        := Result;
 828                      when SCP => Stack_Check_Probes_On_Target        := Result;
 829                      when SLS => Support_Long_Shifts_On_Target       := Result;
 830                      when SSL => Suppress_Standard_Library_On_Target := Result;
 831                      when SNZ => Signed_Zeros_On_Target              := Result;
 832                      when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
 833                      when ZCX => ZCX_By_Default_On_Target            := Result;
 834
 835                      goto Line_Loop_Continue;
 836                   end case;
 837
 838                   --  Here we are seeing a parameter we do not understand. We
 839                   --  simply ignore this (will happen when an old compiler is
 840                   --  used to compile a newer version of GNAT which does not
 841                   --  support the parameter).
 842                end if;
 843             end loop Config_Param_Loop;
 844          end if;
 845
 846          --  Here after processing one line of System spec
 847
 848          <<Line_Loop_Continue>>
 849
 850          while P < Source_Last
 851            and then System_Text (P) /= CR
 852            and then System_Text (P) /= LF
 853          loop
 854             P := P + 1;
 855          end loop;
 856
 857          while P < Source_Last
 858            and then (System_Text (P) = CR
 859                        or else System_Text (P) = LF)
 860          loop
 861             P := P + 1;
 862          end loop;
 863
 864          if P >= Source_Last then
 865             Set_Standard_Error;
 866             Write_Line ("fatal error, system.ads not formatted correctly");
 867             Write_Line ("unexpected end of file");
 868             Set_Standard_Output;
 869             raise Unrecoverable_Error;
 870          end if;
 871       end loop;
 872
 873       if Fatal then
 874          raise Unrecoverable_Error;
 875       end if;
 876    end Get_Target_Parameters;
 877
 878    ------------------------------
 879    -- Set_Profile_Restrictions --
 880    ------------------------------
 881
 882    procedure Set_Profile_Restrictions (P : Profile_Name) is
 883       R : Restriction_Flags  renames Profile_Info (P).Set;
 884       V : Restriction_Values renames Profile_Info (P).Value;
 885    begin
 886       for J in R'Range loop
 887          if R (J) then
 888             Restrictions_On_Target.Set (J) := True;
 889
 890             if J in All_Parameter_Restrictions then
 891                Restrictions_On_Target.Value (J) := V (J);
 892             end if;
 893          end if;
 894       end loop;
 895    end Set_Profile_Restrictions;
 896
 897 end Targparm;