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 with Uintp;  use Uintp;
  33
  34 package body Targparm is
  35    use ASCII;
  36
  37    Parameters_Obtained : Boolean := False;
  38    --  Set True after first call to Get_Target_Parameters. Used to avoid
  39    --  reading system.ads more than once, since it cannot change.
  40
  41    --  The following array defines a tag name for each entry
  42
  43    type Targparm_Tags is
  44      (AAM,  --   AAMP
  45       BDC,  --   Backend_Divide_Checks
  46       BOC,  --   Backend_Overflow_Checks
  47       CLA,  --   Command_Line_Args
  48       CRT,  --   Configurable_Run_Time
  49       D32,  --   Duration_32_Bits
  50       DEN,  --   Denorm
  51       DSP,  --   Functions_Return_By_DSP
  52       EXS,  --   Exit_Status_Supported
  53       FEL,  --   Frontend_Layout
  54       FFO,  --   Fractional_Fixed_Ops
  55       MOV,  --   Machine_Overflows
  56       MRN,  --   Machine_Rounds
  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    S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides";
  99    SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
 100    SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
 101    SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
 102    SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
 103    SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
 104    SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
 105    SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
 106    SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
 107    UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
 108    VMS_Str : aliased constant Source_Buffer := "OpenVMS";
 109    ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
 110    ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
 111    ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
 112
 113    --  Obsolete entries
 114
 115    HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
 116    LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
 117
 118    --  The following defines a set of pointers to the above strings,
 119    --  indexed by the tag values.
 120
 121    type Buffer_Ptr is access constant Source_Buffer;
 122    Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
 123      (AAM_Str'Access,
 124       BDC_Str'Access,
 125       BOC_Str'Access,
 126       CLA_Str'Access,
 127       CRT_Str'Access,
 128       D32_Str'Access,
 129       DEN_Str'Access,
 130       DSP_Str'Access,
 131       EXS_Str'Access,
 132       FEL_Str'Access,
 133       FFO_Str'Access,
 134       MOV_Str'Access,
 135       MRN_Str'Access,
 136       S64_Str'Access,
 137       SAG_Str'Access,
 138       SCA_Str'Access,
 139       SCC_Str'Access,
 140       SCD_Str'Access,
 141       SCP_Str'Access,
 142       SLS_Str'Access,
 143       SNZ_Str'Access,
 144       SSL_Str'Access,
 145       UAM_Str'Access,
 146       VMS_Str'Access,
 147       ZCD_Str'Access,
 148       ZCG_Str'Access,
 149       ZCF_Str'Access,
 150
 151       --  Obsolete entries
 152
 153       HIM_Str'Access,
 154       LSI_Str'Access);
 155
 156    ---------------------------
 157    -- Get_Target_Parameters --
 158    ---------------------------
 159
 160    --  Version which reads in system.ads
 161
 162    procedure Get_Target_Parameters is
 163       Text : Source_Buffer_Ptr;
 164       Hi   : Source_Ptr;
 165
 166    begin
 167       if Parameters_Obtained then
 168          return;
 169       end if;
 170
 171       Name_Buffer (1 .. 10) := "system.ads";
 172       Name_Len := 10;
 173
 174       Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
 175
 176       if Text = null then
 177          Write_Line ("fatal error, run-time library not installed correctly");
 178          Write_Line ("cannot locate file system.ads");
 179          raise Unrecoverable_Error;
 180       end if;
 181
 182       Targparm.Get_Target_Parameters
 183         (System_Text  => Text,
 184          Source_First => 0,
 185          Source_Last  => Hi);
 186    end Get_Target_Parameters;
 187
 188    --  Version where caller supplies system.ads text
 189
 190    procedure Get_Target_Parameters
 191      (System_Text  : Source_Buffer_Ptr;
 192       Source_First : Source_Ptr;
 193       Source_Last  : Source_Ptr)
 194    is
 195       P : Source_Ptr;
 196       V : Uint;
 197
 198       Fatal : Boolean := False;
 199       --  Set True if a fatal error is detected
 200
 201       Result : Boolean;
 202       --  Records boolean from system line
 203
 204    begin
 205       if Parameters_Obtained then
 206          return;
 207       else
 208          Parameters_Obtained := True;
 209       end if;
 210
 211       P := Source_First;
 212       Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
 213
 214          --  Skip comments quickly
 215
 216          if System_Text (P) = '-' then
 217             goto Line_Loop_Continue;
 218
 219          --  Test for pragma Restrictions
 220
 221          elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
 222             P := P + 21;
 223
 224             Rloop : for K in Partition_Boolean_Restrictions loop
 225                declare
 226                   Rname : constant String := Restriction_Id'Image (K);
 227
 228                begin
 229                   for J in Rname'Range loop
 230                      if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
 231                                                         /= Rname (J)
 232                      then
 233                         goto Rloop_Continue;
 234                      end if;
 235                   end loop;
 236
 237                   if System_Text (P + Rname'Length) = ')' then
 238                      Restrictions_On_Target.Set (K) := True;
 239                      goto Line_Loop_Continue;
 240                   end if;
 241                end;
 242
 243             <<Rloop_Continue>>
 244                null;
 245             end loop Rloop;
 246
 247             Ploop : for K in All_Parameter_Restrictions loop
 248                declare
 249                   Rname : constant String :=
 250                             All_Parameter_Restrictions'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 Ploop_Continue;
 258                      end if;
 259                   end loop;
 260
 261                   if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
 262                                                       " => "
 263                   then
 264                      P := P + Rname'Length + 4;
 265                      V := Uint_0;
 266
 267                      loop
 268                         if System_Text (P) in '0' .. '9' then
 269                            V := 10 * V + Character'Pos (System_Text (P)) - 48;
 270                         elsif System_Text (P) = '_' then
 271                            null;
 272                         elsif System_Text (P) = ')' then
 273                            if UI_Is_In_Int_Range (V) then
 274                               Restrictions_On_Target.Value (K) :=
 275                                 Integer (UI_To_Int (V));
 276                               Restrictions_On_Target.Set (K) := True;
 277                               goto Line_Loop_Continue;
 278                            else
 279                               exit Ploop;
 280                            end if;
 281                         else
 282                            exit Ploop;
 283                         end if;
 284
 285                         P := P + 1;
 286                      end loop;
 287
 288                   else
 289                      exit Ploop;
 290                   end if;
 291                end;
 292
 293             <<Ploop_Continue>>
 294                null;
 295             end loop Ploop;
 296
 297             Set_Standard_Error;
 298             Write_Line
 299                ("fatal error: system.ads is incorrectly formatted");
 300             Write_Str ("unrecognized or incorrect restrictions pragma: ");
 301
 302             while System_Text (P) /= ')'
 303                     and then
 304                   System_Text (P) /= ASCII.LF
 305             loop
 306                Write_Char (System_Text (P));
 307                P := P + 1;
 308             end loop;
 309
 310             Write_Eol;
 311             Fatal := True;
 312             Set_Standard_Output;
 313
 314          --  Discard_Names
 315
 316          elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
 317             P := P + 21;
 318             Opt.Global_Discard_Names := True;
 319             goto Line_Loop_Continue;
 320
 321          --  Locking Policy
 322
 323          elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
 324             P := P + 23;
 325             Opt.Locking_Policy := System_Text (P);
 326             Opt.Locking_Policy_Sloc := System_Location;
 327             goto Line_Loop_Continue;
 328
 329          --  Normalize_Scalars
 330
 331          elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
 332             P := P + 25;
 333             Opt.Normalize_Scalars := True;
 334             Opt.Init_Or_Norm_Scalars := True;
 335             goto Line_Loop_Continue;
 336
 337          --  Polling (On)
 338
 339          elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
 340             P := P + 20;
 341             Opt.Polling_Required := True;
 342             goto Line_Loop_Continue;
 343
 344          --  Ignore pragma Pure (System)
 345
 346          elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
 347             P := P + 21;
 348             goto Line_Loop_Continue;
 349
 350          --  Queuing Policy
 351
 352          elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
 353             P := P + 23;
 354             Opt.Queuing_Policy := System_Text (P);
 355             Opt.Queuing_Policy_Sloc := System_Location;
 356             goto Line_Loop_Continue;
 357
 358          --  Suppress_Exception_Locations
 359
 360          elsif System_Text (P .. P + 34) =
 361                                 "pragma Suppress_Exception_Locations;"
 362          then
 363             P := P + 35;
 364             Opt.Exception_Locations_Suppressed := True;
 365             goto Line_Loop_Continue;
 366
 367          --  Task_Dispatching Policy
 368
 369          elsif System_Text (P .. P + 31) =
 370                                    "pragma Task_Dispatching_Policy ("
 371          then
 372             P := P + 32;
 373             Opt.Task_Dispatching_Policy := System_Text (P);
 374             Opt.Task_Dispatching_Policy_Sloc := System_Location;
 375             goto Line_Loop_Continue;
 376
 377          --  No other pragmas are permitted
 378
 379          elsif System_Text (P .. P + 6) = "pragma " then
 380             Set_Standard_Error;
 381             Write_Line ("unrecognized line in system.ads: ");
 382
 383             while System_Text (P) /= ')'
 384               and then System_Text (P) /= ASCII.LF
 385             loop
 386                Write_Char (System_Text (P));
 387                P := P + 1;
 388             end loop;
 389
 390             Write_Eol;
 391             Set_Standard_Output;
 392             Fatal := True;
 393
 394          --  See if we have a Run_Time_Name
 395
 396          elsif System_Text (P .. P + 38) =
 397                   "   Run_Time_Name : constant String := """
 398          then
 399             P := P + 39;
 400
 401             Name_Len := 0;
 402             while System_Text (P) in 'A' .. 'Z'
 403                     or else
 404                   System_Text (P) in 'a' .. 'z'
 405                     or else
 406                   System_Text (P) in '0' .. '9'
 407                     or else
 408                   System_Text (P) = ' '
 409                     or else
 410                   System_Text (P) = '_'
 411             loop
 412                Add_Char_To_Name_Buffer (System_Text (P));
 413                P := P + 1;
 414             end loop;
 415
 416             if System_Text (P) /= '"'
 417               or else System_Text (P + 1) /= ';'
 418               or else (System_Text (P + 2) /= ASCII.LF
 419                          and then
 420                        System_Text (P + 2) /= ASCII.CR)
 421             then
 422                Set_Standard_Error;
 423                Write_Line
 424                  ("incorrectly formatted Run_Time_Name in system.ads");
 425                Set_Standard_Output;
 426                Fatal := True;
 427
 428             else
 429                Run_Time_Name_On_Target := Name_Enter;
 430             end if;
 431
 432             goto Line_Loop_Continue;
 433
 434          --  Next See if we have a configuration parameter
 435
 436          else
 437             Config_Param_Loop : for K in Targparm_Tags loop
 438                if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
 439                                                       Targparm_Str (K).all
 440                then
 441                   P := P + 3 + Targparm_Str (K)'Length;
 442
 443
 444                   if Targparm_Flags (K) then
 445                      Set_Standard_Error;
 446                      Write_Line
 447                        ("fatal error: system.ads is incorrectly formatted");
 448                      Write_Str ("duplicate line for parameter: ");
 449
 450                      for J in Targparm_Str (K)'Range loop
 451                         Write_Char (Targparm_Str (K).all (J));
 452                      end loop;
 453
 454                      Write_Eol;
 455                      Set_Standard_Output;
 456                      Fatal := True;
 457
 458                   else
 459                      Targparm_Flags (K) := True;
 460                   end if;
 461
 462                   while System_Text (P) /= ':'
 463                      or else System_Text (P + 1) /= '='
 464                   loop
 465                      P := P + 1;
 466                   end loop;
 467
 468                   P := P + 2;
 469
 470                   while System_Text (P) = ' ' loop
 471                      P := P + 1;
 472                   end loop;
 473
 474                   Result := (System_Text (P) = 'T');
 475
 476                   case K is
 477                      when AAM => AAMP_On_Target                      := Result;
 478                      when BDC => Backend_Divide_Checks_On_Target     := Result;
 479                      when BOC => Backend_Overflow_Checks_On_Target   := Result;
 480                      when CLA => Command_Line_Args_On_Target         := Result;
 481                      when CRT => Configurable_Run_Time_On_Target     := Result;
 482                      when D32 => Duration_32_Bits_On_Target          := Result;
 483                      when DEN => Denorm_On_Target                    := Result;
 484                      when DSP => Functions_Return_By_DSP_On_Target   := Result;
 485                      when EXS => Exit_Status_Supported_On_Target     := Result;
 486                      when FEL => Frontend_Layout_On_Target           := Result;
 487                      when FFO => Fractional_Fixed_Ops_On_Target      := Result;
 488                      when MOV => Machine_Overflows_On_Target         := Result;
 489                      when MRN => Machine_Rounds_On_Target            := Result;
 490                      when S64 => Support_64_Bit_Divides_On_Target    := Result;
 491                      when SAG => Support_Aggregates_On_Target        := Result;
 492                      when SCA => Support_Composite_Assign_On_Target  := Result;
 493                      when SCC => Support_Composite_Compare_On_Target := Result;
 494                      when SCD => Stack_Check_Default_On_Target       := Result;
 495                      when SCP => Stack_Check_Probes_On_Target        := Result;
 496                      when SLS => Support_Long_Shifts_On_Target       := Result;
 497                      when SSL => Suppress_Standard_Library_On_Target := Result;
 498                      when SNZ => Signed_Zeros_On_Target              := Result;
 499                      when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
 500                      when VMS => OpenVMS_On_Target                   := Result;
 501                      when ZCD => ZCX_By_Default_On_Target            := Result;
 502                      when ZCG => GCC_ZCX_Support_On_Target           := Result;
 503                      when ZCF => Front_End_ZCX_Support_On_Target     := Result;
 504
 505                      --  Obsolete entries
 506
 507                      when HIM => null;
 508                      when LSI => null;
 509
 510                      goto Line_Loop_Continue;
 511                   end case;
 512                end if;
 513             end loop Config_Param_Loop;
 514          end if;
 515
 516          --  Here after processing one line of System spec
 517
 518          <<Line_Loop_Continue>>
 519
 520          while System_Text (P) /= CR and then System_Text (P) /= LF loop
 521             P := P + 1;
 522             exit when P >= Source_Last;
 523          end loop;
 524
 525          while System_Text (P) = CR or else System_Text (P) = LF loop
 526             P := P + 1;
 527             exit when P >= Source_Last;
 528          end loop;
 529
 530          if P >= Source_Last then
 531             Set_Standard_Error;
 532             Write_Line ("fatal error, system.ads not formatted correctly");
 533             Write_Line ("unexpected end of file");
 534             Set_Standard_Output;
 535             raise Unrecoverable_Error;
 536          end if;
 537       end loop Line_Loop;
 538
 539       --  Check no missing target parameter settings
 540
 541       for K in Targparm_Tags_OK loop
 542          if not Targparm_Flags (K) then
 543             Set_Standard_Error;
 544             Write_Line
 545               ("fatal error: system.ads is incorrectly formatted");
 546             Write_Str ("missing line for parameter: ");
 547
 548             for J in Targparm_Str (K)'Range loop
 549                Write_Char (Targparm_Str (K).all (J));
 550             end loop;
 551
 552             Write_Eol;
 553             Set_Standard_Output;
 554             Fatal := True;
 555          end if;
 556       end loop;
 557
 558       if Fatal then
 559          raise Unrecoverable_Error;
 560       end if;
 561    end Get_Target_Parameters;
 562
 563 end Targparm;