887 lines
31 KiB
Ada
887 lines
31 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT RUN-TIME COMPONENTS --
|
|
-- --
|
|
-- T A R G P A R M --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1999-2015, 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
|
|
ASD, -- Atomic_Sync_Default
|
|
BDC, -- Backend_Divide_Checks
|
|
BOC, -- Backend_Overflow_Checks
|
|
CLA, -- Command_Line_Args
|
|
CRT, -- Configurable_Run_Times
|
|
D32, -- Duration_32_Bits
|
|
DEN, -- Denorm
|
|
EXS, -- Exit_Status_Supported
|
|
FEL, -- Frontend_Layout
|
|
FEX, -- Frontend_Exceptions
|
|
FFO, -- Fractional_Fixed_Ops
|
|
MOV, -- Machine_Overflows
|
|
MRN, -- Machine_Rounds
|
|
PAS, -- Preallocated_Stacks
|
|
SAG, -- Support_Aggregates
|
|
SAP, -- Support_Atomic_Primitives
|
|
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
|
|
ZCX); -- 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";
|
|
ASD_Str : aliased constant Source_Buffer := "Atomic_Sync_Default";
|
|
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";
|
|
EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
|
|
FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
|
|
FEX_Str : aliased constant Source_Buffer := "Frontend_Exceptions";
|
|
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";
|
|
SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
|
|
SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives";
|
|
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";
|
|
ZCX_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,
|
|
ASD_Str'Access,
|
|
BDC_Str'Access,
|
|
BOC_Str'Access,
|
|
CLA_Str'Access,
|
|
CRT_Str'Access,
|
|
D32_Str'Access,
|
|
DEN_Str'Access,
|
|
EXS_Str'Access,
|
|
FEL_Str'Access,
|
|
FEX_Str'Access,
|
|
FFO_Str'Access,
|
|
MOV_Str'Access,
|
|
MRN_Str'Access,
|
|
PAS_Str'Access,
|
|
SAG_Str'Access,
|
|
SAP_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,
|
|
ZCX_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
|
|
(Make_Id : Make_Id_Type := null;
|
|
Make_SC : Make_SC_Type := null;
|
|
Set_NOD : Set_NOD_Type := null;
|
|
Set_NSA : Set_NSA_Type := null;
|
|
Set_NUA : Set_NUA_Type := null;
|
|
Set_NUP : Set_NUP_Type := null)
|
|
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,
|
|
Make_Id => Make_Id,
|
|
Make_SC => Make_SC,
|
|
Set_NOD => Set_NOD,
|
|
Set_NSA => Set_NSA,
|
|
Set_NUA => Set_NUA,
|
|
Set_NUP => Set_NUP);
|
|
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;
|
|
Make_Id : Make_Id_Type := null;
|
|
Make_SC : Make_SC_Type := null;
|
|
Set_NOD : Set_NOD_Type := null;
|
|
Set_NSA : Set_NSA_Type := null;
|
|
Set_NUA : Set_NUA_Type := null;
|
|
Set_NUP : Set_NUP_Type := null)
|
|
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
|
|
|
|
OK : Boolean;
|
|
-- Status result from Set_NUP/NSA/NUA call
|
|
|
|
PR_Start : Source_Ptr;
|
|
-- Pointer to ( following pragma Restrictions
|
|
|
|
procedure Collect_Name;
|
|
-- Scan a name starting at System_Text (P), and put Name in Name_Buffer,
|
|
-- with Name_Len being length, folded to lower case. On return, P points
|
|
-- just past the last character (which should be a right paren).
|
|
|
|
------------------
|
|
-- Collect_Name --
|
|
------------------
|
|
|
|
procedure Collect_Name is
|
|
begin
|
|
Name_Len := 0;
|
|
loop
|
|
if System_Text (P) in 'a' .. 'z'
|
|
or else
|
|
System_Text (P) = '_'
|
|
or else
|
|
System_Text (P) in '0' .. '9'
|
|
then
|
|
Name_Buffer (Name_Len + 1) := System_Text (P);
|
|
|
|
elsif System_Text (P) in 'A' .. 'Z' then
|
|
Name_Buffer (Name_Len + 1) :=
|
|
Character'Val (Character'Pos (System_Text (P)) + 32);
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
|
|
P := P + 1;
|
|
Name_Len := Name_Len + 1;
|
|
end loop;
|
|
end Collect_Name;
|
|
|
|
-- Start of processing for Get_Target_Parameters
|
|
|
|
begin
|
|
if Parameters_Obtained then
|
|
return;
|
|
else
|
|
Parameters_Obtained := True;
|
|
end if;
|
|
|
|
Opt.Address_Is_Private := False;
|
|
|
|
-- Loop through source lines
|
|
|
|
-- Note: in the case or pragmas, we are only interested in pragmas that
|
|
-- appear as configuration pragmas. These are left justified, so they
|
|
-- do not have three spaces at the start. Pragmas appearing within the
|
|
-- package (like Pure and No_Elaboration_Code_All) will have the three
|
|
-- spaces at the start and so will be ignored.
|
|
|
|
-- For a special exception, see processing for pragma Pure below
|
|
|
|
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 (GNAT_Extended_Ravenscar);
|
|
|
|
elsif System_Text (P .. P + 40) =
|
|
"pragma Profile (GNAT_Extended_Ravenscar);"
|
|
then
|
|
Set_Profile_Restrictions (GNAT_Extended_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;
|
|
PR_Start := P - 1;
|
|
|
|
-- Boolean restrictions
|
|
|
|
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;
|
|
|
|
-- Restrictions taking integer parameter
|
|
|
|
Ploop : for K in Integer_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;
|
|
|
|
-- No_Dependence case
|
|
|
|
if System_Text (P .. P + 16) = "No_Dependence => " then
|
|
P := P + 17;
|
|
|
|
-- Skip this processing (and simply ignore No_Dependence lines)
|
|
-- if caller did not supply the three subprograms we need to
|
|
-- process these lines.
|
|
|
|
if Make_Id = null then
|
|
goto Line_Loop_Continue;
|
|
end if;
|
|
|
|
-- We have scanned out "pragma Restrictions (No_Dependence =>"
|
|
|
|
declare
|
|
Unit : Node_Id;
|
|
Id : Node_Id;
|
|
Start : Source_Ptr;
|
|
|
|
begin
|
|
Unit := Empty;
|
|
|
|
-- Loop through components of name, building up Unit
|
|
|
|
loop
|
|
Start := P;
|
|
while System_Text (P) /= '.'
|
|
and then
|
|
System_Text (P) /= ')'
|
|
loop
|
|
P := P + 1;
|
|
end loop;
|
|
|
|
Id := Make_Id (System_Text (Start .. P - 1));
|
|
|
|
-- If first name, just capture the identifier
|
|
|
|
if Unit = Empty then
|
|
Unit := Id;
|
|
else
|
|
Unit := Make_SC (Unit, Id);
|
|
end if;
|
|
|
|
exit when System_Text (P) = ')';
|
|
P := P + 1;
|
|
end loop;
|
|
|
|
Set_NOD (Unit);
|
|
goto Line_Loop_Continue;
|
|
end;
|
|
|
|
-- No_Specification_Of_Aspect case
|
|
|
|
elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => "
|
|
then
|
|
P := P + 30;
|
|
|
|
-- Skip this processing (and simply ignore the pragma), if
|
|
-- caller did not supply the subprogram we need to process
|
|
-- such lines.
|
|
|
|
if Set_NSA = null then
|
|
goto Line_Loop_Continue;
|
|
end if;
|
|
|
|
-- We have scanned
|
|
-- "pragma Restrictions (No_Specification_Of_Aspect =>"
|
|
|
|
Collect_Name;
|
|
|
|
if System_Text (P) /= ')' then
|
|
goto Bad_Restrictions_Pragma;
|
|
|
|
else
|
|
Set_NSA (Name_Find, OK);
|
|
|
|
if OK then
|
|
goto Line_Loop_Continue;
|
|
else
|
|
goto Bad_Restrictions_Pragma;
|
|
end if;
|
|
end if;
|
|
|
|
-- No_Use_Of_Attribute case
|
|
|
|
elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then
|
|
P := P + 23;
|
|
|
|
-- Skip this processing (and simply ignore No_Use_Of_Attribute
|
|
-- lines) if caller did not supply the subprogram we need to
|
|
-- process such lines.
|
|
|
|
if Set_NUA = null then
|
|
goto Line_Loop_Continue;
|
|
end if;
|
|
|
|
-- We have scanned
|
|
-- "pragma Restrictions (No_Use_Of_Attribute =>"
|
|
|
|
Collect_Name;
|
|
|
|
if System_Text (P) /= ')' then
|
|
goto Bad_Restrictions_Pragma;
|
|
|
|
else
|
|
Set_NUA (Name_Find, OK);
|
|
|
|
if OK then
|
|
goto Line_Loop_Continue;
|
|
else
|
|
goto Bad_Restrictions_Pragma;
|
|
end if;
|
|
end if;
|
|
|
|
-- No_Use_Of_Pragma case
|
|
|
|
elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then
|
|
P := P + 20;
|
|
|
|
-- Skip this processing (and simply ignore No_Use_Of_Pragma
|
|
-- lines) if caller did not supply the subprogram we need to
|
|
-- process such lines.
|
|
|
|
if Set_NUP = null then
|
|
goto Line_Loop_Continue;
|
|
end if;
|
|
|
|
-- We have scanned
|
|
-- "pragma Restrictions (No_Use_Of_Pragma =>"
|
|
|
|
Collect_Name;
|
|
|
|
if System_Text (P) /= ')' then
|
|
goto Bad_Restrictions_Pragma;
|
|
|
|
else
|
|
Set_NUP (Name_Find, OK);
|
|
|
|
if OK then
|
|
goto Line_Loop_Continue;
|
|
else
|
|
goto Bad_Restrictions_Pragma;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- Here if unrecognizable restrictions pragma form
|
|
|
|
<<Bad_Restrictions_Pragma>>
|
|
|
|
Set_Standard_Error;
|
|
Write_Line
|
|
("fatal error: system.ads is incorrectly formatted");
|
|
Write_Str ("unrecognized or incorrect restrictions pragma: ");
|
|
|
|
P := PR_Start;
|
|
loop
|
|
exit when System_Text (P) = ASCII.LF;
|
|
Write_Char (System_Text (P));
|
|
exit when 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;
|
|
|
|
-- Partition_Elaboration_Policy
|
|
|
|
elsif System_Text (P .. P + 36) =
|
|
"pragma Partition_Elaboration_Policy ("
|
|
then
|
|
P := P + 37;
|
|
Opt.Partition_Elaboration_Policy := System_Text (P);
|
|
Opt.Partition_Elaboration_Policy_Sloc := System_Location;
|
|
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;
|
|
|
|
-- 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 configuration pragmas are permitted
|
|
|
|
elsif System_Text (P .. P + 6) = "pragma " then
|
|
|
|
-- Special exception, we allow pragma Pure (System) appearing in
|
|
-- column one. This is an obsolete usage which may show up in old
|
|
-- tests with an obsolete version of system.ads, so we recognize
|
|
-- and ignore it to make life easier in handling such tests.
|
|
|
|
if System_Text (P .. P + 20) = "pragma Pure (System);" then
|
|
P := P + 21;
|
|
goto Line_Loop_Continue;
|
|
end if;
|
|
|
|
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 ASD => Atomic_Sync_Default_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 EXS => Exit_Status_Supported_On_Target := Result;
|
|
when FEL => Frontend_Layout_On_Target := Result;
|
|
when FEX => Frontend_Exceptions_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 SAG => Support_Aggregates_On_Target := Result;
|
|
when SAP => Support_Atomic_Primitives_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 ZCX => 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;
|
|
|
|
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;
|