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