------------------------------------------------------------------------------ -- -- -- 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; <> 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; <> 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 <> 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;