diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/targparm.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/targparm.adb | 638 |
1 files changed, 0 insertions, 638 deletions
diff --git a/gcc-4.2.1/gcc/ada/targparm.adb b/gcc-4.2.1/gcc/ada/targparm.adb deleted file mode 100644 index 829535d86..000000000 --- a/gcc-4.2.1/gcc/ada/targparm.adb +++ /dev/null @@ -1,638 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- T A R G P A R M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2005, 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- 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 Namet; use Namet; -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 - BDC, -- Backend_Divide_Checks - BOC, -- Backend_Overflow_Checks - CLA, -- Command_Line_Args - CRT, -- Configurable_Run_Times - CSV, -- Compiler_System_Version - D32, -- Duration_32_Bits - DEN, -- Denorm - DSP, -- Functions_Return_By_DSP - EXS, -- Exit_Status_Supported - FEL, -- Frontend_Layout - FFO, -- Fractional_Fixed_Ops - MOV, -- Machine_Overflows - MRN, -- Machine_Rounds - PAS, -- Preallocated_Stacks - S64, -- Support_64_Bit_Divides - SAG, -- Support_Aggregates - SCA, -- Support_Composite_Assign - SCC, -- Support_Composite_Compare - SCD, -- Stack_Check_Default - 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 - ZCG); -- GCC_ZCX_Support - - subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCG; - -- Range excluding obsolete entries - - 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"; - 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"; - CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; - CSV_Str : aliased constant Source_Buffer := "Compiler_System_Version"; - D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; - DEN_Str : aliased constant Source_Buffer := "Denorm"; - DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP"; - 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"; - MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; - MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; - PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; - S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides"; - 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"; - 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"; - ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support"; - - -- 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, - BDC_Str'Access, - BOC_Str'Access, - CLA_Str'Access, - CRT_Str'Access, - CSV_Str'Access, - D32_Str'Access, - DEN_Str'Access, - DSP_Str'Access, - EXS_Str'Access, - FEL_Str'Access, - FFO_Str'Access, - MOV_Str'Access, - MRN_Str'Access, - PAS_Str'Access, - S64_Str'Access, - SAG_Str'Access, - SCA_Str'Access, - SCC_Str'Access, - SCD_Str'Access, - SCP_Str'Access, - SLS_Str'Access, - SNZ_Str'Access, - SSL_Str'Access, - UAM_Str'Access, - VMS_Str'Access, - ZCD_Str'Access, - ZCG_Str'Access); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Set_Profile_Restrictions (P : Profile_Name); - -- Set Restrictions_On_Target for the given profile - - ------------------------------ - -- 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; - - --------------------------- - -- 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; - - Targparm.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 + 34) = - "pragma Suppress_Exception_Locations;" - then - P := P + 35; - 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; - - -- 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 BDC => Backend_Divide_Checks_On_Target := Result; - when BOC => Backend_Overflow_Checks_On_Target := Result; - when CLA => Command_Line_Args_On_Target := Result; - when CRT => Configurable_Run_Time_On_Target := Result; - when CSV => Compiler_System_Version := Result; - when D32 => Duration_32_Bits_On_Target := Result; - when DEN => Denorm_On_Target := Result; - when DSP => Functions_Return_By_DSP_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 MOV => Machine_Overflows_On_Target := Result; - when MRN => Machine_Rounds_On_Target := Result; - when PAS => Preallocated_Stacks_On_Target := Result; - when S64 => Support_64_Bit_Divides_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 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; - when ZCG => GCC_ZCX_Support_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 - 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; - - -- Check no missing target parameter settings (skip for compiler vsn) - - if not Compiler_System_Version then - for K in Targparm_Tags_OK loop - if not Targparm_Flags (K) then - Set_Standard_Error; - Write_Line - ("fatal error: system.ads is incorrectly formatted"); - Write_Str ("missing 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; - end if; - end loop; - end if; - - if Fatal then - raise Unrecoverable_Error; - end if; - end Get_Target_Parameters; - -end Targparm; |