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