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