URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [targparm.adb] - Rev 523
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- T A R G P A R M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2009, 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 S64, -- Support_64_Bit_Divides 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 ZCG); -- GCC_ZCX_Support 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"; 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"; 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"; 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, 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, S64_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, ZCG_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 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 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; 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 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;
Go to most recent revision | Compare with Previous | Blame | View Log