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