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