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;
type Targparm_Tags is
(AAM, BDC, BOC, CLA, CRT, D32, DEN, DSP, EXS, FEL, FFO, MOV, MRN, PAS, S64, SAG, SCA, SCC, SCD, SCP, SLS, SNZ, SSL, UAM, VMS, ZCD, ZCG, ZCF,
HIM, LSI);
subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCF;
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
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";
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";
ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
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,
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,
ZCF_Str'Access,
HIM_Str'Access,
LSI_Str'Access);
procedure Set_Profile_Restrictions (P : Profile_Name);
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;
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;
procedure Get_Target_Parameters
(System_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr)
is
P : Source_Ptr;
Fatal : Boolean := False;
Result : Boolean;
begin
if Parameters_Obtained then
return;
else
Parameters_Obtained := True;
end if;
P := Source_First;
Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
if System_Text (P) = '-' then
goto Line_Loop_Continue;
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;
elsif System_Text (P .. P + 27) =
"pragma Profile (Restricted);"
then
Set_Profile_Restrictions (Restricted);
P := P + 28;
goto Line_Loop_Continue;
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;
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
V := 10 * V +
Character'Pos (System_Text (P)) -
Character'Pos ('0');
exception
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;
elsif System_Text (P .. P + 22) = "pragma Detect_Blocking;" then
P := P + 23;
Opt.Detect_Blocking := True;
goto Line_Loop_Continue;
elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
P := P + 21;
Opt.Global_Discard_Names := True;
goto Line_Loop_Continue;
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;
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;
elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
P := P + 20;
Opt.Polling_Required := True;
goto Line_Loop_Continue;
elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
P := P + 21;
goto Line_Loop_Continue;
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;
elsif System_Text (P .. P + 34) =
"pragma Suppress_Exception_Locations;"
then
P := P + 35;
Opt.Exception_Locations_Suppressed := True;
goto Line_Loop_Continue;
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;
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;
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;
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 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;
when ZCF => Front_End_ZCX_Support_On_Target := Result;
when HIM => null;
when LSI => null;
goto Line_Loop_Continue;
end case;
end if;
end loop Config_Param_Loop;
end if;
<<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;
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;
if Fatal then
raise Unrecoverable_Error;
end if;
end Get_Target_Parameters;
end Targparm;