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