Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                        GNAT RUN-TIME COMPONENTS                          --

--                                                                          --

--                             T A R G P A R M                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1999-2011, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Csets;    use Csets;

with Opt;      use Opt;

with Osint;    use Osint;

with Output;   use Output;

package body Targparm is

   use ASCII;

   Parameters_Obtained : Boolean := False;

   --  Set True after first call to Get_Target_Parameters. Used to avoid

   --  reading system.ads more than once, since it cannot change.

   --  The following array defines a tag name for each entry

   type Targparm_Tags is

     (AAM,  --   AAMP

      ACR,  --   Always_Compatible_Rep

      BDC,  --   Backend_Divide_Checks

      BOC,  --   Backend_Overflow_Checks

      CLA,  --   Command_Line_Args

      CLI,  --   CLI (.NET)

      CRT,  --   Configurable_Run_Times

      D32,  --   Duration_32_Bits

      DEN,  --   Denorm

      EXS,  --   Exit_Status_Supported

      FEL,  --   Frontend_Layout

      FFO,  --   Fractional_Fixed_Ops

      JVM,  --   JVM

      MOV,  --   Machine_Overflows

      MRN,  --   Machine_Rounds

      PAS,  --   Preallocated_Stacks

      RTX,  --   RTX_RTSS_Kernel_Module

      SAG,  --   Support_Aggregates

      SCA,  --   Support_Composite_Assign

      SCC,  --   Support_Composite_Compare

      SCD,  --   Stack_Check_Default

      SCL,  --   Stack_Check_Limits

      SCP,  --   Stack_Check_Probes

      SLS,  --   Support_Long_Shifts

      SNZ,  --   Signed_Zeros

      SSL,  --   Suppress_Standard_Library

      UAM,  --   Use_Ada_Main_Program_Name

      VMS,  --   OpenVMS

      ZCD); --   ZCX_By_Default

   Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);

   --  Flag is set True if corresponding parameter is scanned

   --  The following list of string constants gives the parameter names

   AAM_Str : aliased constant Source_Buffer := "AAMP";

   ACR_Str : aliased constant Source_Buffer := "Always_Compatible_Rep";

   BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";

   BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";

   CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";

   CLI_Str : aliased constant Source_Buffer := "CLI";

   CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";

   D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";

   DEN_Str : aliased constant Source_Buffer := "Denorm";

   EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";

   FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";

   FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";

   JVM_Str : aliased constant Source_Buffer := "JVM";

   MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";

   MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";

   PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks";

   RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module";

   SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";

   SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";

   SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";

   SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";

   SCL_Str : aliased constant Source_Buffer := "Stack_Check_Limits";

   SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";

   SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";

   SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";

   SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";

   UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";

   VMS_Str : aliased constant Source_Buffer := "OpenVMS";

   ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";

   --  The following defines a set of pointers to the above strings,

   --  indexed by the tag values.

   type Buffer_Ptr is access constant Source_Buffer;

   Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=

     (AAM_Str'Access,

      ACR_Str'Access,

      BDC_Str'Access,

      BOC_Str'Access,

      CLA_Str'Access,

      CLI_Str'Access,

      CRT_Str'Access,

      D32_Str'Access,

      DEN_Str'Access,

      EXS_Str'Access,

      FEL_Str'Access,

      FFO_Str'Access,

      JVM_Str'Access,

      MOV_Str'Access,

      MRN_Str'Access,

      PAS_Str'Access,

      RTX_Str'Access,

      SAG_Str'Access,

      SCA_Str'Access,

      SCC_Str'Access,

      SCD_Str'Access,

      SCL_Str'Access,

      SCP_Str'Access,

      SLS_Str'Access,

      SNZ_Str'Access,

      SSL_Str'Access,

      UAM_Str'Access,

      VMS_Str'Access,

      ZCD_Str'Access);

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Set_Profile_Restrictions (P : Profile_Name);

   --  Set Restrictions_On_Target for the given profile

   ---------------------------

   -- Get_Target_Parameters --

   ---------------------------

   --  Version which reads in system.ads

   procedure Get_Target_Parameters is

      Text : Source_Buffer_Ptr;

      Hi   : Source_Ptr;

   begin

      if Parameters_Obtained then

         return;

      end if;

      Name_Buffer (1 .. 10) := "system.ads";

      Name_Len := 10;

      Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);

      if Text = null then

         Write_Line ("fatal error, run-time library not installed correctly");

         Write_Line ("cannot locate file system.ads");

         raise Unrecoverable_Error;

      end if;

      Get_Target_Parameters

        (System_Text  => Text,

         Source_First => 0,

         Source_Last  => Hi);

   end Get_Target_Parameters;

   --  Version where caller supplies system.ads text

   procedure Get_Target_Parameters

     (System_Text  : Source_Buffer_Ptr;

      Source_First : Source_Ptr;

      Source_Last  : Source_Ptr)

   is

      P : Source_Ptr;

      --  Scans source buffer containing source of system.ads

      Fatal : Boolean := False;

      --  Set True if a fatal error is detected

      Result : Boolean;

      --  Records boolean from system line

   begin

      if Parameters_Obtained then

         return;

      else

         Parameters_Obtained := True;

      end if;

      Opt.Address_Is_Private := False;

      P := Source_First;

      Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop

         --  Skip comments quickly

         if System_Text (P) = '-' then

            goto Line_Loop_Continue;

         --  Test for type Address is private

         elsif System_Text (P .. P + 26) = "   type Address is private;" then

            Opt.Address_Is_Private := True;

            P := P + 26;

            goto Line_Loop_Continue;

         --  Test for pragma Profile (Ravenscar);

         elsif System_Text (P .. P + 26) =

                 "pragma Profile (Ravenscar);"

         then

            Set_Profile_Restrictions (Ravenscar);

            Opt.Task_Dispatching_Policy := 'F';

            Opt.Locking_Policy          := 'C';

            P := P + 27;

            goto Line_Loop_Continue;

         --  Test for pragma Profile (Restricted);

         elsif System_Text (P .. P + 27) =

                 "pragma Profile (Restricted);"

         then

            Set_Profile_Restrictions (Restricted);

            P := P + 28;

            goto Line_Loop_Continue;

         --  Test for pragma Restrictions

         elsif System_Text (P .. P + 20) = "pragma Restrictions (" then

            P := P + 21;

            Rloop : for K in All_Boolean_Restrictions loop

               declare

                  Rname : constant String := Restriction_Id'Image (K);

               begin

                  for J in Rname'Range loop

                     if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))

                                                        /= Rname (J)

                     then

                        goto Rloop_Continue;

                     end if;

                  end loop;

                  if System_Text (P + Rname'Length) = ')' then

                     Restrictions_On_Target.Set (K) := True;

                     goto Line_Loop_Continue;

                  end if;

               end;

            <<Rloop_Continue>>

               null;

            end loop Rloop;

            Ploop : for K in All_Parameter_Restrictions loop

               declare

                  Rname : constant String :=

                            All_Parameter_Restrictions'Image (K);

                  V : Natural;

                  --  Accumulates value

               begin

                  for J in Rname'Range loop

                     if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))

                                                        /= Rname (J)

                     then

                        goto Ploop_Continue;

                     end if;

                  end loop;

                  if System_Text (P + Rname'Length .. P + Rname'Length + 3) =

                                                      " => "

                  then

                     P := P + Rname'Length + 4;

                     V := 0;

                     loop

                        if System_Text (P) in '0' .. '9' then

                           declare

                              pragma Unsuppress (Overflow_Check);

                           begin

                              --  Accumulate next digit

                              V := 10 * V +

                                   Character'Pos (System_Text (P)) -

                                   Character'Pos ('0');

                           exception

                              --  On overflow, we just ignore the pragma since

                              --  that is the standard handling in this case.

                              when Constraint_Error =>

                                 goto Line_Loop_Continue;

                           end;

                        elsif System_Text (P) = '_' then

                           null;

                        elsif System_Text (P) = ')' then

                           Restrictions_On_Target.Value (K) := V;

                           Restrictions_On_Target.Set (K) := True;

                           goto Line_Loop_Continue;

                        else

                           exit Ploop;

                        end if;

                        P := P + 1;

                     end loop;

                  else

                     exit Ploop;

                  end if;

               end;

            <<Ploop_Continue>>

               null;

            end loop Ploop;

            Set_Standard_Error;

            Write_Line

               ("fatal error: system.ads is incorrectly formatted");

            Write_Str ("unrecognized or incorrect restrictions pragma: ");

            while System_Text (P) /= ')'

                    and then

                  System_Text (P) /= ASCII.LF

            loop

               Write_Char (System_Text (P));

               P := P + 1;

            end loop;

            Write_Eol;

            Fatal := True;

            Set_Standard_Output;

         --  Test for pragma Detect_Blocking;

         elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then

            P := P + 23;

            Opt.Detect_Blocking := True;

            goto Line_Loop_Continue;

         --  Discard_Names

         elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then

            P := P + 21;

            Opt.Global_Discard_Names := True;

            goto Line_Loop_Continue;

         --  Locking Policy

         elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then

            P := P + 23;

            Opt.Locking_Policy := System_Text (P);

            Opt.Locking_Policy_Sloc := System_Location;

            goto Line_Loop_Continue;

         --  Normalize_Scalars

         elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then

            P := P + 25;

            Opt.Normalize_Scalars := True;

            Opt.Init_Or_Norm_Scalars := True;

            goto Line_Loop_Continue;

         --  Polling (On)

         elsif System_Text (P .. P + 19) = "pragma Polling (On);" then

            P := P + 20;

            Opt.Polling_Required := True;

            goto Line_Loop_Continue;

         --  Ignore pragma Pure (System)

         elsif System_Text (P .. P + 20) = "pragma Pure (System);" then

            P := P + 21;

            goto Line_Loop_Continue;

         --  Queuing Policy

         elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then

            P := P + 23;

            Opt.Queuing_Policy := System_Text (P);

            Opt.Queuing_Policy_Sloc := System_Location;

            goto Line_Loop_Continue;

         --  Suppress_Exception_Locations

         elsif System_Text (P .. P + 35) =

                                   "pragma Suppress_Exception_Locations;"

         then

            P := P + 36;

            Opt.Exception_Locations_Suppressed := True;

            goto Line_Loop_Continue;

         --  Task_Dispatching Policy

         elsif System_Text (P .. P + 31) =

                                   "pragma Task_Dispatching_Policy ("

         then

            P := P + 32;

            Opt.Task_Dispatching_Policy := System_Text (P);

            Opt.Task_Dispatching_Policy_Sloc := System_Location;

            goto Line_Loop_Continue;

         --  No other pragmas are permitted

         elsif System_Text (P .. P + 6) = "pragma " then

            Set_Standard_Error;

            Write_Line ("unrecognized line in system.ads: ");

            while System_Text (P) /= ')'

              and then System_Text (P) /= ASCII.LF

            loop

               Write_Char (System_Text (P));

               P := P + 1;

            end loop;

            Write_Eol;

            Set_Standard_Output;

            Fatal := True;

         --  See if we have a Run_Time_Name

         elsif System_Text (P .. P + 38) =

                  "   Run_Time_Name : constant String := """

         then

            P := P + 39;

            Name_Len := 0;

            while System_Text (P) in 'A' .. 'Z'

                    or else

                  System_Text (P) in 'a' .. 'z'

                    or else

                  System_Text (P) in '0' .. '9'

                    or else

                  System_Text (P) = ' '

                    or else

                  System_Text (P) = '_'

            loop

               Add_Char_To_Name_Buffer (System_Text (P));

               P := P + 1;

            end loop;

            if System_Text (P) /= '"'

              or else System_Text (P + 1) /= ';'

              or else (System_Text (P + 2) /= ASCII.LF

                         and then

                       System_Text (P + 2) /= ASCII.CR)

            then

               Set_Standard_Error;

               Write_Line

                 ("incorrectly formatted Run_Time_Name in system.ads");

               Set_Standard_Output;

               Fatal := True;

            else

               Run_Time_Name_On_Target := Name_Enter;

            end if;

            goto Line_Loop_Continue;

         --  See if we have an Executable_Extension

         elsif System_Text (P .. P + 45) =

                  "   Executable_Extension : constant String := """

         then

            P := P + 46;

            Name_Len := 0;

            while System_Text (P) /= '"'

              and then System_Text (P) /= ASCII.LF

            loop

               Add_Char_To_Name_Buffer (System_Text (P));

               P := P + 1;

            end loop;

            if System_Text (P) /= '"' or else System_Text (P + 1) /= ';' then

               Set_Standard_Error;

               Write_Line

                 ("incorrectly formatted Executable_Extension in system.ads");

               Set_Standard_Output;

               Fatal := True;

            else

               Executable_Extension_On_Target := Name_Enter;

            end if;

            goto Line_Loop_Continue;

         --  Next see if we have a configuration parameter

         else

            Config_Param_Loop : for K in Targparm_Tags loop

               if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =

                                                      Targparm_Str (K).all

               then

                  P := P + 3 + Targparm_Str (K)'Length;

                  if Targparm_Flags (K) then

                     Set_Standard_Error;

                     Write_Line

                       ("fatal error: system.ads is incorrectly formatted");

                     Write_Str ("duplicate line for parameter: ");

                     for J in Targparm_Str (K)'Range loop

                        Write_Char (Targparm_Str (K).all (J));

                     end loop;

                     Write_Eol;

                     Set_Standard_Output;

                     Fatal := True;

                  else

                     Targparm_Flags (K) := True;

                  end if;

                  while System_Text (P) /= ':'

                     or else System_Text (P + 1) /= '='

                  loop

                     P := P + 1;

                  end loop;

                  P := P + 2;

                  while System_Text (P) = ' ' loop

                     P := P + 1;

                  end loop;

                  Result := (System_Text (P) = 'T');

                  case K is

                     when AAM => AAMP_On_Target                      := Result;

                     when ACR => Always_Compatible_Rep_On_Target     := Result;

                     when BDC => Backend_Divide_Checks_On_Target     := Result;

                     when BOC => Backend_Overflow_Checks_On_Target   := Result;

                     when CLA => Command_Line_Args_On_Target         := Result;

                     when CLI =>

                        if Result then

                           VM_Target := CLI_Target;

                           Tagged_Type_Expansion := False;

                        end if;

                     when CRT => Configurable_Run_Time_On_Target     := Result;

                     when D32 => Duration_32_Bits_On_Target          := Result;

                     when DEN => Denorm_On_Target                    := Result;

                     when EXS => Exit_Status_Supported_On_Target     := Result;

                     when FEL => Frontend_Layout_On_Target           := Result;

                     when FFO => Fractional_Fixed_Ops_On_Target      := Result;

                     when JVM =>

                        if Result then

                           VM_Target := JVM_Target;

                           Tagged_Type_Expansion := False;

                        end if;

                     when MOV => Machine_Overflows_On_Target         := Result;

                     when MRN => Machine_Rounds_On_Target            := Result;

                     when PAS => Preallocated_Stacks_On_Target       := Result;

                     when RTX => RTX_RTSS_Kernel_Module_On_Target    := Result;

                     when SAG => Support_Aggregates_On_Target        := Result;

                     when SCA => Support_Composite_Assign_On_Target  := Result;

                     when SCC => Support_Composite_Compare_On_Target := Result;

                     when SCD => Stack_Check_Default_On_Target       := Result;

                     when SCL => Stack_Check_Limits_On_Target        := Result;

                     when SCP => Stack_Check_Probes_On_Target        := Result;

                     when SLS => Support_Long_Shifts_On_Target       := Result;

                     when SSL => Suppress_Standard_Library_On_Target := Result;

                     when SNZ => Signed_Zeros_On_Target              := Result;

                     when UAM => Use_Ada_Main_Program_Name_On_Target := Result;

                     when VMS => OpenVMS_On_Target                   := Result;

                     when ZCD => ZCX_By_Default_On_Target            := Result;

                     goto Line_Loop_Continue;

                  end case;

                  --  Here we are seeing a parameter we do not understand. We

                  --  simply ignore this (will happen when an old compiler is

                  --  used to compile a newer version of GNAT which does not

                  --  support the parameter).

               end if;

            end loop Config_Param_Loop;

         end if;

         --  Here after processing one line of System spec

         <<Line_Loop_Continue>>

         while System_Text (P) /= CR and then System_Text (P) /= LF loop

            P := P + 1;

            exit when P >= Source_Last;

         end loop;

         while System_Text (P) = CR or else System_Text (P) = LF loop

            P := P + 1;

            exit when P >= Source_Last;

         end loop;

         if P >= Source_Last then

            Set_Standard_Error;

            Write_Line ("fatal error, system.ads not formatted correctly");

            Write_Line ("unexpected end of file");

            Set_Standard_Output;

            raise Unrecoverable_Error;

         end if;

      end loop Line_Loop;

      --  Now that OpenVMS_On_Target has been given its definitive value,

      --  change the multi-unit index character from '~' to '$' for OpenVMS.

      if OpenVMS_On_Target then

         Multi_Unit_Index_Character := '$';

      end if;

      if Fatal then

         raise Unrecoverable_Error;

      end if;

   end Get_Target_Parameters;

   ------------------------------

   -- Set_Profile_Restrictions --

   ------------------------------

   procedure Set_Profile_Restrictions (P : Profile_Name) is

      R : Restriction_Flags  renames Profile_Info (P).Set;

      V : Restriction_Values renames Profile_Info (P).Value;

   begin

      for J in R'Range loop

         if R (J) then

            Restrictions_On_Target.Set (J) := True;

            if J in All_Parameter_Restrictions then

               Restrictions_On_Target.Value (J) := V (J);

            end if;

         end if;

      end loop;

   end Set_Profile_Restrictions;

end Targparm;